diff --git a/404.html b/404.html index dd9d21a3e..41ec0257a 100644 --- a/404.html +++ b/404.html @@ -63,6 +63,7 @@ id="dropdown-versions">Versions
diff --git a/CODE_OF_CONDUCT.html b/CODE_OF_CONDUCT.html index 0872f1559..b9230a960 100644 --- a/CODE_OF_CONDUCT.html +++ b/CODE_OF_CONDUCT.html @@ -47,6 +47,7 @@ id="dropdown-versions">Versions diff --git a/CONTRIBUTING.html b/CONTRIBUTING.html index 24188853a..7938738c2 100644 --- a/CONTRIBUTING.html +++ b/CONTRIBUTING.html @@ -47,6 +47,7 @@ id="dropdown-versions">Versions diff --git a/LICENSE-text.html b/LICENSE-text.html index 820c985ee..8c76f0a06 100644 --- a/LICENSE-text.html +++ b/LICENSE-text.html @@ -47,6 +47,7 @@ id="dropdown-versions">Versions diff --git a/SECURITY.html b/SECURITY.html index 43868211b..03e1b5ba7 100644 --- a/SECURITY.html +++ b/SECURITY.html @@ -47,6 +47,7 @@ id="dropdown-versions">Versions diff --git a/articles/index.html b/articles/index.html index 96b5ace4c..036008cd0 100644 --- a/articles/index.html +++ b/articles/index.html @@ -47,6 +47,7 @@ id="dropdown-versions">Versions diff --git a/articles/teal-modules-general.html b/articles/teal-modules-general.html index b57fb5d3e..5c8eae62a 100644 --- a/articles/teal-modules-general.html +++ b/articles/teal-modules-general.html @@ -65,6 +65,7 @@ id="dropdown-versions">Versions diff --git a/articles/using-association-plot.html b/articles/using-association-plot.html index 898182a87..0954e5f9c 100644 --- a/articles/using-association-plot.html +++ b/articles/using-association-plot.html @@ -65,6 +65,7 @@ id="dropdown-versions">Versions diff --git a/articles/using-bivariate-plot.html b/articles/using-bivariate-plot.html index c54a41bca..897da81c3 100644 --- a/articles/using-bivariate-plot.html +++ b/articles/using-bivariate-plot.html @@ -65,6 +65,7 @@ id="dropdown-versions">Versions diff --git a/articles/using-cross-table.html b/articles/using-cross-table.html index 2ffe915fc..1679d57e5 100644 --- a/articles/using-cross-table.html +++ b/articles/using-cross-table.html @@ -65,6 +65,7 @@ id="dropdown-versions">Versions diff --git a/articles/using-outliers-module.html b/articles/using-outliers-module.html index e0361818a..4d2c5d563 100644 --- a/articles/using-outliers-module.html +++ b/articles/using-outliers-module.html @@ -65,6 +65,7 @@ id="dropdown-versions">Versions diff --git a/articles/using-regression-plots.html b/articles/using-regression-plots.html index 7fa96780b..aa6b910bf 100644 --- a/articles/using-regression-plots.html +++ b/articles/using-regression-plots.html @@ -65,6 +65,7 @@ id="dropdown-versions">Versions diff --git a/articles/using-response-plot.html b/articles/using-response-plot.html index 2994c6613..44ef711f3 100644 --- a/articles/using-response-plot.html +++ b/articles/using-response-plot.html @@ -65,6 +65,7 @@ id="dropdown-versions">Versions diff --git a/articles/using-scatterplot-matrix.html b/articles/using-scatterplot-matrix.html index e9a3ffa98..356d913cf 100644 --- a/articles/using-scatterplot-matrix.html +++ b/articles/using-scatterplot-matrix.html @@ -65,6 +65,7 @@ id="dropdown-versions">Versions diff --git a/articles/using-scatterplot.html b/articles/using-scatterplot.html index 6fdf173af..2a02d3aaa 100644 --- a/articles/using-scatterplot.html +++ b/articles/using-scatterplot.html @@ -65,6 +65,7 @@ id="dropdown-versions">Versions diff --git a/authors.html b/authors.html index a0d359444..7969dee13 100644 --- a/authors.html +++ b/authors.html @@ -47,6 +47,7 @@ id="dropdown-versions">Versions diff --git a/latest-tag/404.html b/latest-tag/404.html index ec68b4318..c5d4e7e30 100644 --- a/latest-tag/404.html +++ b/latest-tag/404.html @@ -64,6 +64,7 @@ id="dropdown-versions">Versions diff --git a/latest-tag/CODE_OF_CONDUCT.html b/latest-tag/CODE_OF_CONDUCT.html index 0fe1589f4..7b2db47d0 100644 --- a/latest-tag/CODE_OF_CONDUCT.html +++ b/latest-tag/CODE_OF_CONDUCT.html @@ -48,6 +48,7 @@ id="dropdown-versions">Versions diff --git a/latest-tag/CONTRIBUTING.html b/latest-tag/CONTRIBUTING.html index 3f2c775e1..c4671a697 100644 --- a/latest-tag/CONTRIBUTING.html +++ b/latest-tag/CONTRIBUTING.html @@ -48,6 +48,7 @@ id="dropdown-versions">Versions diff --git a/latest-tag/LICENSE-text.html b/latest-tag/LICENSE-text.html index 0f6d93564..69cc6bb6d 100644 --- a/latest-tag/LICENSE-text.html +++ b/latest-tag/LICENSE-text.html @@ -48,6 +48,7 @@ id="dropdown-versions">Versions diff --git a/latest-tag/SECURITY.html b/latest-tag/SECURITY.html index a6d7f42cb..077200684 100644 --- a/latest-tag/SECURITY.html +++ b/latest-tag/SECURITY.html @@ -48,6 +48,7 @@ id="dropdown-versions">Versions diff --git a/latest-tag/articles/index.html b/latest-tag/articles/index.html index b843663f3..d6ec4ad05 100644 --- a/latest-tag/articles/index.html +++ b/latest-tag/articles/index.html @@ -48,6 +48,7 @@ id="dropdown-versions">Versions diff --git a/latest-tag/articles/teal-modules-general.html b/latest-tag/articles/teal-modules-general.html index ab089685e..599e50fef 100644 --- a/latest-tag/articles/teal-modules-general.html +++ b/latest-tag/articles/teal-modules-general.html @@ -66,6 +66,7 @@ id="dropdown-versions">Versions diff --git a/latest-tag/articles/using-association-plot.html b/latest-tag/articles/using-association-plot.html index 2415a0654..b3ff1694d 100644 --- a/latest-tag/articles/using-association-plot.html +++ b/latest-tag/articles/using-association-plot.html @@ -66,6 +66,7 @@ id="dropdown-versions">Versions diff --git a/latest-tag/articles/using-bivariate-plot.html b/latest-tag/articles/using-bivariate-plot.html index 87ffffea9..8b74c854f 100644 --- a/latest-tag/articles/using-bivariate-plot.html +++ b/latest-tag/articles/using-bivariate-plot.html @@ -66,6 +66,7 @@ id="dropdown-versions">Versions diff --git a/latest-tag/articles/using-cross-table.html b/latest-tag/articles/using-cross-table.html index 5166e055d..e62249037 100644 --- a/latest-tag/articles/using-cross-table.html +++ b/latest-tag/articles/using-cross-table.html @@ -66,6 +66,7 @@ id="dropdown-versions">Versions diff --git a/latest-tag/articles/using-data-table.html b/latest-tag/articles/using-data-table.html index fc580f2c1..210c83114 100644 --- a/latest-tag/articles/using-data-table.html +++ b/latest-tag/articles/using-data-table.html @@ -66,6 +66,7 @@ id="dropdown-versions">Versions diff --git a/latest-tag/articles/using-outliers-module.html b/latest-tag/articles/using-outliers-module.html index e047d41d9..d72817b5f 100644 --- a/latest-tag/articles/using-outliers-module.html +++ b/latest-tag/articles/using-outliers-module.html @@ -66,6 +66,7 @@ id="dropdown-versions">Versions diff --git a/latest-tag/articles/using-regression-plots.html b/latest-tag/articles/using-regression-plots.html index f843737e6..cf171584d 100644 --- a/latest-tag/articles/using-regression-plots.html +++ b/latest-tag/articles/using-regression-plots.html @@ -66,6 +66,7 @@ id="dropdown-versions">Versions diff --git a/latest-tag/articles/using-response-plot.html b/latest-tag/articles/using-response-plot.html index babe8337e..232486b4a 100644 --- a/latest-tag/articles/using-response-plot.html +++ b/latest-tag/articles/using-response-plot.html @@ -66,6 +66,7 @@ id="dropdown-versions">Versions diff --git a/latest-tag/articles/using-scatterplot-matrix.html b/latest-tag/articles/using-scatterplot-matrix.html index a2128abc3..f782cc35e 100644 --- a/latest-tag/articles/using-scatterplot-matrix.html +++ b/latest-tag/articles/using-scatterplot-matrix.html @@ -66,6 +66,7 @@ id="dropdown-versions">Versions diff --git a/latest-tag/articles/using-scatterplot.html b/latest-tag/articles/using-scatterplot.html index b4cf7af3a..b38db27f2 100644 --- a/latest-tag/articles/using-scatterplot.html +++ b/latest-tag/articles/using-scatterplot.html @@ -66,6 +66,7 @@ id="dropdown-versions">Versions diff --git a/latest-tag/authors.html b/latest-tag/authors.html index d7fedad68..dccec54bb 100644 --- a/latest-tag/authors.html +++ b/latest-tag/authors.html @@ -48,6 +48,7 @@ id="dropdown-versions">Versions diff --git a/latest-tag/index.html b/latest-tag/index.html index 28c117342..45725427a 100644 --- a/latest-tag/index.html +++ b/latest-tag/index.html @@ -66,6 +66,7 @@ id="dropdown-versions">Versions diff --git a/latest-tag/news/index.html b/latest-tag/news/index.html index 5e94aa937..2d0a2359f 100644 --- a/latest-tag/news/index.html +++ b/latest-tag/news/index.html @@ -48,6 +48,7 @@ id="dropdown-versions">Versions diff --git a/latest-tag/pull_request_template.html b/latest-tag/pull_request_template.html index 9542b8cf5..0d466b899 100644 --- a/latest-tag/pull_request_template.html +++ b/latest-tag/pull_request_template.html @@ -48,6 +48,7 @@ id="dropdown-versions">Versions diff --git a/latest-tag/reference/add_facet_labels.html b/latest-tag/reference/add_facet_labels.html index 16be97d77..786771ea6 100644 --- a/latest-tag/reference/add_facet_labels.html +++ b/latest-tag/reference/add_facet_labels.html @@ -48,6 +48,7 @@ id="dropdown-versions">Versions diff --git a/latest-tag/reference/call_fun_dots.html b/latest-tag/reference/call_fun_dots.html index 4d8be3f44..5c02ceadd 100644 --- a/latest-tag/reference/call_fun_dots.html +++ b/latest-tag/reference/call_fun_dots.html @@ -48,6 +48,7 @@ id="dropdown-versions">Versions diff --git a/latest-tag/reference/create_sparklines.html b/latest-tag/reference/create_sparklines.html index 7f0ba755a..122f0fe32 100644 --- a/latest-tag/reference/create_sparklines.html +++ b/latest-tag/reference/create_sparklines.html @@ -56,6 +56,7 @@ id="dropdown-versions">Versions diff --git a/latest-tag/reference/establish_updating_selection.html b/latest-tag/reference/establish_updating_selection.html index 58c5292e1..57d9e47ce 100644 --- a/latest-tag/reference/establish_updating_selection.html +++ b/latest-tag/reference/establish_updating_selection.html @@ -50,6 +50,7 @@ id="dropdown-versions">Versions diff --git a/latest-tag/reference/extract_input.html b/latest-tag/reference/extract_input.html index 06dcdd0ce..9f545eeaa 100644 --- a/latest-tag/reference/extract_input.html +++ b/latest-tag/reference/extract_input.html @@ -50,6 +50,7 @@ id="dropdown-versions">Versions diff --git a/latest-tag/reference/get_scatterplotmatrix_stats.html b/latest-tag/reference/get_scatterplotmatrix_stats.html index dadff51e0..ffbf646d6 100644 --- a/latest-tag/reference/get_scatterplotmatrix_stats.html +++ b/latest-tag/reference/get_scatterplotmatrix_stats.html @@ -52,6 +52,7 @@ id="dropdown-versions">Versions diff --git a/latest-tag/reference/get_var_description.html b/latest-tag/reference/get_var_description.html index 1e0ddaf8d..234f40b17 100644 --- a/latest-tag/reference/get_var_description.html +++ b/latest-tag/reference/get_var_description.html @@ -52,6 +52,7 @@ id="dropdown-versions">Versions diff --git a/latest-tag/reference/include_css_files.html b/latest-tag/reference/include_css_files.html index 0cc3de484..3bf24d846 100644 --- a/latest-tag/reference/include_css_files.html +++ b/latest-tag/reference/include_css_files.html @@ -52,6 +52,7 @@ id="dropdown-versions">Versions diff --git a/latest-tag/reference/index.html b/latest-tag/reference/index.html index 817e36cbd..cdda5ddc1 100644 --- a/latest-tag/reference/index.html +++ b/latest-tag/reference/index.html @@ -48,6 +48,7 @@ id="dropdown-versions">Versions diff --git a/latest-tag/reference/is_tab_active_js.html b/latest-tag/reference/is_tab_active_js.html index f4581ca8c..23d58436c 100644 --- a/latest-tag/reference/is_tab_active_js.html +++ b/latest-tag/reference/is_tab_active_js.html @@ -48,6 +48,7 @@ id="dropdown-versions">Versions diff --git a/latest-tag/reference/plot_var_summary.html b/latest-tag/reference/plot_var_summary.html index 9d6419f42..65768187d 100644 --- a/latest-tag/reference/plot_var_summary.html +++ b/latest-tag/reference/plot_var_summary.html @@ -48,6 +48,7 @@ id="dropdown-versions">Versions diff --git a/latest-tag/reference/rADAE.html b/latest-tag/reference/rADAE.html index 32f15de36..62e9f2bdf 100644 --- a/latest-tag/reference/rADAE.html +++ b/latest-tag/reference/rADAE.html @@ -48,6 +48,7 @@ id="dropdown-versions">Versions diff --git a/latest-tag/reference/rADLB.html b/latest-tag/reference/rADLB.html index 670ee3b43..ee5af1237 100644 --- a/latest-tag/reference/rADLB.html +++ b/latest-tag/reference/rADLB.html @@ -48,6 +48,7 @@ id="dropdown-versions">Versions diff --git a/latest-tag/reference/rADRS.html b/latest-tag/reference/rADRS.html index e47650cfd..e744e23ec 100644 --- a/latest-tag/reference/rADRS.html +++ b/latest-tag/reference/rADRS.html @@ -48,6 +48,7 @@ id="dropdown-versions">Versions diff --git a/latest-tag/reference/rADSL.html b/latest-tag/reference/rADSL.html index f816a48d2..977fe31d0 100644 --- a/latest-tag/reference/rADSL.html +++ b/latest-tag/reference/rADSL.html @@ -48,6 +48,7 @@ id="dropdown-versions">Versions diff --git a/latest-tag/reference/rADTTE.html b/latest-tag/reference/rADTTE.html index 93e7f2102..104345b48 100644 --- a/latest-tag/reference/rADTTE.html +++ b/latest-tag/reference/rADTTE.html @@ -48,6 +48,7 @@ id="dropdown-versions">Versions diff --git a/latest-tag/reference/remove_outliers_from.html b/latest-tag/reference/remove_outliers_from.html index 639b0be0e..fa8d9ac83 100644 --- a/latest-tag/reference/remove_outliers_from.html +++ b/latest-tag/reference/remove_outliers_from.html @@ -48,6 +48,7 @@ id="dropdown-versions">Versions diff --git a/latest-tag/reference/render_single_tab.html b/latest-tag/reference/render_single_tab.html index 183bc7046..66427459e 100644 --- a/latest-tag/reference/render_single_tab.html +++ b/latest-tag/reference/render_single_tab.html @@ -50,6 +50,7 @@ id="dropdown-versions">Versions diff --git a/latest-tag/reference/render_tab_header.html b/latest-tag/reference/render_tab_header.html index 3abb89452..31f77f0c2 100644 --- a/latest-tag/reference/render_tab_header.html +++ b/latest-tag/reference/render_tab_header.html @@ -48,6 +48,7 @@ id="dropdown-versions">Versions diff --git a/latest-tag/reference/render_tab_table.html b/latest-tag/reference/render_tab_table.html index b584abac1..e6f22f118 100644 --- a/latest-tag/reference/render_tab_table.html +++ b/latest-tag/reference/render_tab_table.html @@ -50,6 +50,7 @@ id="dropdown-versions">Versions diff --git a/latest-tag/reference/render_tabset_panel_content.html b/latest-tag/reference/render_tabset_panel_content.html index 1d4451324..cfedaf843 100644 --- a/latest-tag/reference/render_tabset_panel_content.html +++ b/latest-tag/reference/render_tabset_panel_content.html @@ -48,6 +48,7 @@ id="dropdown-versions">Versions diff --git a/latest-tag/reference/shared_params.html b/latest-tag/reference/shared_params.html index e24219a4a..95b5bb7ef 100644 --- a/latest-tag/reference/shared_params.html +++ b/latest-tag/reference/shared_params.html @@ -50,6 +50,7 @@ id="dropdown-versions">Versions diff --git a/latest-tag/reference/teal.modules.general.html b/latest-tag/reference/teal.modules.general.html index 9c4282afb..f91fee6ea 100644 --- a/latest-tag/reference/teal.modules.general.html +++ b/latest-tag/reference/teal.modules.general.html @@ -50,6 +50,7 @@ id="dropdown-versions">Versions diff --git a/latest-tag/reference/tm_a_pca.html b/latest-tag/reference/tm_a_pca.html index 4ae72e395..9a695d21c 100644 --- a/latest-tag/reference/tm_a_pca.html +++ b/latest-tag/reference/tm_a_pca.html @@ -48,6 +48,7 @@ id="dropdown-versions">Versions diff --git a/latest-tag/reference/tm_a_regression.html b/latest-tag/reference/tm_a_regression.html index 78b0a5fe4..e29b35244 100644 --- a/latest-tag/reference/tm_a_regression.html +++ b/latest-tag/reference/tm_a_regression.html @@ -48,6 +48,7 @@ id="dropdown-versions">Versions diff --git a/latest-tag/reference/tm_data_table.html b/latest-tag/reference/tm_data_table.html index 06be52e16..3fda2ea83 100644 --- a/latest-tag/reference/tm_data_table.html +++ b/latest-tag/reference/tm_data_table.html @@ -48,6 +48,7 @@ id="dropdown-versions">Versions diff --git a/latest-tag/reference/tm_file_viewer.html b/latest-tag/reference/tm_file_viewer.html index c86ec4944..b5b6773f4 100644 --- a/latest-tag/reference/tm_file_viewer.html +++ b/latest-tag/reference/tm_file_viewer.html @@ -52,6 +52,7 @@ id="dropdown-versions">Versions diff --git a/latest-tag/reference/tm_front_page.html b/latest-tag/reference/tm_front_page.html index b116af6e7..41b25d6aa 100644 --- a/latest-tag/reference/tm_front_page.html +++ b/latest-tag/reference/tm_front_page.html @@ -48,6 +48,7 @@ id="dropdown-versions">Versions diff --git a/latest-tag/reference/tm_g_association.html b/latest-tag/reference/tm_g_association.html index 0548af291..6e2172fe5 100644 --- a/latest-tag/reference/tm_g_association.html +++ b/latest-tag/reference/tm_g_association.html @@ -48,6 +48,7 @@ id="dropdown-versions">Versions diff --git a/latest-tag/reference/tm_g_bivariate.html b/latest-tag/reference/tm_g_bivariate.html index e89b7e5c4..9e8046ab1 100644 --- a/latest-tag/reference/tm_g_bivariate.html +++ b/latest-tag/reference/tm_g_bivariate.html @@ -48,6 +48,7 @@ id="dropdown-versions">Versions diff --git a/latest-tag/reference/tm_g_distribution.html b/latest-tag/reference/tm_g_distribution.html index 9a72d9cbe..d88133fd8 100644 --- a/latest-tag/reference/tm_g_distribution.html +++ b/latest-tag/reference/tm_g_distribution.html @@ -48,6 +48,7 @@ id="dropdown-versions">Versions diff --git a/latest-tag/reference/tm_g_response.html b/latest-tag/reference/tm_g_response.html index 13a6ed455..96aa1b4d8 100644 --- a/latest-tag/reference/tm_g_response.html +++ b/latest-tag/reference/tm_g_response.html @@ -48,6 +48,7 @@ id="dropdown-versions">Versions diff --git a/latest-tag/reference/tm_g_scatterplot.html b/latest-tag/reference/tm_g_scatterplot.html index 985dacc28..97244f761 100644 --- a/latest-tag/reference/tm_g_scatterplot.html +++ b/latest-tag/reference/tm_g_scatterplot.html @@ -48,6 +48,7 @@ id="dropdown-versions">Versions diff --git a/latest-tag/reference/tm_g_scatterplotmatrix.html b/latest-tag/reference/tm_g_scatterplotmatrix.html index 9cf7bb407..24724ddd9 100644 --- a/latest-tag/reference/tm_g_scatterplotmatrix.html +++ b/latest-tag/reference/tm_g_scatterplotmatrix.html @@ -50,6 +50,7 @@ id="dropdown-versions">Versions diff --git a/latest-tag/reference/tm_missing_data.html b/latest-tag/reference/tm_missing_data.html index 49f177856..704f44481 100644 --- a/latest-tag/reference/tm_missing_data.html +++ b/latest-tag/reference/tm_missing_data.html @@ -48,6 +48,7 @@ id="dropdown-versions">Versions diff --git a/latest-tag/reference/tm_outliers.html b/latest-tag/reference/tm_outliers.html index ed8ad217e..125f55cf6 100644 --- a/latest-tag/reference/tm_outliers.html +++ b/latest-tag/reference/tm_outliers.html @@ -48,6 +48,7 @@ id="dropdown-versions">Versions diff --git a/latest-tag/reference/tm_t_crosstable.html b/latest-tag/reference/tm_t_crosstable.html index 28035a03d..55f0262f7 100644 --- a/latest-tag/reference/tm_t_crosstable.html +++ b/latest-tag/reference/tm_t_crosstable.html @@ -48,6 +48,7 @@ id="dropdown-versions">Versions diff --git a/latest-tag/reference/tm_variable_browser.html b/latest-tag/reference/tm_variable_browser.html index e31623848..847945f74 100644 --- a/latest-tag/reference/tm_variable_browser.html +++ b/latest-tag/reference/tm_variable_browser.html @@ -50,6 +50,7 @@ id="dropdown-versions">Versions diff --git a/latest-tag/reference/validate_input.html b/latest-tag/reference/validate_input.html index 3f908da95..636c908b2 100644 --- a/latest-tag/reference/validate_input.html +++ b/latest-tag/reference/validate_input.html @@ -48,6 +48,7 @@ id="dropdown-versions">Versions diff --git a/latest-tag/reference/var_labels.html b/latest-tag/reference/var_labels.html index 73a946b72..f0eb0f8eb 100644 --- a/latest-tag/reference/var_labels.html +++ b/latest-tag/reference/var_labels.html @@ -52,6 +52,7 @@ id="dropdown-versions">Versions diff --git a/latest-tag/reference/var_missings_info.html b/latest-tag/reference/var_missings_info.html index acb986bfd..aaeeb9416 100644 --- a/latest-tag/reference/var_missings_info.html +++ b/latest-tag/reference/var_missings_info.html @@ -48,6 +48,7 @@ id="dropdown-versions">Versions diff --git a/latest-tag/reference/var_summary_table.html b/latest-tag/reference/var_summary_table.html index 6a5a34d3b..566c45cdc 100644 --- a/latest-tag/reference/var_summary_table.html +++ b/latest-tag/reference/var_summary_table.html @@ -52,6 +52,7 @@ id="dropdown-versions">Versions diff --git a/latest-tag/reference/variable_type_icons.html b/latest-tag/reference/variable_type_icons.html index 72c952704..1cf959e53 100644 --- a/latest-tag/reference/variable_type_icons.html +++ b/latest-tag/reference/variable_type_icons.html @@ -48,6 +48,7 @@ id="dropdown-versions">Versions diff --git a/latest-tag/reference/varname_w_label.html b/latest-tag/reference/varname_w_label.html index 2d598a36a..8d4849b46 100644 --- a/latest-tag/reference/varname_w_label.html +++ b/latest-tag/reference/varname_w_label.html @@ -48,6 +48,7 @@ id="dropdown-versions">Versions diff --git a/main/404.html b/main/404.html index dc4abd4fd..0a5fc59cf 100644 --- a/main/404.html +++ b/main/404.html @@ -64,6 +64,7 @@ id="dropdown-versions">Versions diff --git a/main/CODE_OF_CONDUCT.html b/main/CODE_OF_CONDUCT.html index 3e09aba50..e2300985f 100644 --- a/main/CODE_OF_CONDUCT.html +++ b/main/CODE_OF_CONDUCT.html @@ -48,6 +48,7 @@ id="dropdown-versions">Versions diff --git a/main/CONTRIBUTING.html b/main/CONTRIBUTING.html index 0905fb92b..f39f673dc 100644 --- a/main/CONTRIBUTING.html +++ b/main/CONTRIBUTING.html @@ -48,6 +48,7 @@ id="dropdown-versions">Versions diff --git a/main/LICENSE-text.html b/main/LICENSE-text.html index 9bdecc2f2..b8b6ea0e5 100644 --- a/main/LICENSE-text.html +++ b/main/LICENSE-text.html @@ -48,6 +48,7 @@ id="dropdown-versions">Versions diff --git a/main/SECURITY.html b/main/SECURITY.html index e4e477604..cca6c2f22 100644 --- a/main/SECURITY.html +++ b/main/SECURITY.html @@ -48,6 +48,7 @@ id="dropdown-versions">Versions diff --git a/main/articles/index.html b/main/articles/index.html index 7afef48b9..c7a418c66 100644 --- a/main/articles/index.html +++ b/main/articles/index.html @@ -48,6 +48,7 @@ id="dropdown-versions">Versions diff --git a/main/articles/teal-modules-general.html b/main/articles/teal-modules-general.html index 8fc03f7bb..01d7d4c97 100644 --- a/main/articles/teal-modules-general.html +++ b/main/articles/teal-modules-general.html @@ -66,6 +66,7 @@ id="dropdown-versions">Versions diff --git a/main/articles/using-association-plot.html b/main/articles/using-association-plot.html index 7ea9e19b9..233e3f0f1 100644 --- a/main/articles/using-association-plot.html +++ b/main/articles/using-association-plot.html @@ -66,6 +66,7 @@ id="dropdown-versions">Versions diff --git a/main/articles/using-bivariate-plot.html b/main/articles/using-bivariate-plot.html index 7b324668b..ac91f9be8 100644 --- a/main/articles/using-bivariate-plot.html +++ b/main/articles/using-bivariate-plot.html @@ -66,6 +66,7 @@ id="dropdown-versions">Versions diff --git a/main/articles/using-cross-table.html b/main/articles/using-cross-table.html index 8328807e8..7a8ca88c2 100644 --- a/main/articles/using-cross-table.html +++ b/main/articles/using-cross-table.html @@ -66,6 +66,7 @@ id="dropdown-versions">Versions diff --git a/main/articles/using-data-table.html b/main/articles/using-data-table.html index 0ca6984fe..72a9cfc5e 100644 --- a/main/articles/using-data-table.html +++ b/main/articles/using-data-table.html @@ -66,6 +66,7 @@ id="dropdown-versions">Versions diff --git a/main/articles/using-outliers-module.html b/main/articles/using-outliers-module.html index ffde19ee4..ff16ebac1 100644 --- a/main/articles/using-outliers-module.html +++ b/main/articles/using-outliers-module.html @@ -66,6 +66,7 @@ id="dropdown-versions">Versions diff --git a/main/articles/using-regression-plots.html b/main/articles/using-regression-plots.html index e47b64c76..659c280ee 100644 --- a/main/articles/using-regression-plots.html +++ b/main/articles/using-regression-plots.html @@ -66,6 +66,7 @@ id="dropdown-versions">Versions diff --git a/main/articles/using-response-plot.html b/main/articles/using-response-plot.html index d7731e312..43faff298 100644 --- a/main/articles/using-response-plot.html +++ b/main/articles/using-response-plot.html @@ -66,6 +66,7 @@ id="dropdown-versions">Versions diff --git a/main/articles/using-scatterplot-matrix.html b/main/articles/using-scatterplot-matrix.html index 9d63dc23c..6d6c2af9d 100644 --- a/main/articles/using-scatterplot-matrix.html +++ b/main/articles/using-scatterplot-matrix.html @@ -66,6 +66,7 @@ id="dropdown-versions">Versions diff --git a/main/articles/using-scatterplot.html b/main/articles/using-scatterplot.html index bb0c20bdf..be1c8c156 100644 --- a/main/articles/using-scatterplot.html +++ b/main/articles/using-scatterplot.html @@ -66,6 +66,7 @@ id="dropdown-versions">Versions diff --git a/main/authors.html b/main/authors.html index d8d766fc6..f5aea1df2 100644 --- a/main/authors.html +++ b/main/authors.html @@ -48,6 +48,7 @@ id="dropdown-versions">Versions diff --git a/main/index.html b/main/index.html index ee1959475..c35e1f6a4 100644 --- a/main/index.html +++ b/main/index.html @@ -72,6 +72,7 @@ id="dropdown-versions">Versions diff --git a/main/news/index.html b/main/news/index.html index 9d0266fb3..afbfa3916 100644 --- a/main/news/index.html +++ b/main/news/index.html @@ -48,6 +48,7 @@ id="dropdown-versions">Versions diff --git a/main/pull_request_template.html b/main/pull_request_template.html index 037ded3bc..dc72876af 100644 --- a/main/pull_request_template.html +++ b/main/pull_request_template.html @@ -48,6 +48,7 @@ id="dropdown-versions">Versions diff --git a/main/reference/add_facet_labels.html b/main/reference/add_facet_labels.html index 5138c90dd..ae1adf656 100644 --- a/main/reference/add_facet_labels.html +++ b/main/reference/add_facet_labels.html @@ -50,6 +50,7 @@ id="dropdown-versions">Versions diff --git a/main/reference/call_fun_dots.html b/main/reference/call_fun_dots.html index 0db19a580..7b727a4f2 100644 --- a/main/reference/call_fun_dots.html +++ b/main/reference/call_fun_dots.html @@ -48,6 +48,7 @@ id="dropdown-versions">Versions diff --git a/main/reference/create_sparklines.html b/main/reference/create_sparklines.html index 83a4ecfe8..720d89a79 100644 --- a/main/reference/create_sparklines.html +++ b/main/reference/create_sparklines.html @@ -52,6 +52,7 @@ id="dropdown-versions">Versions diff --git a/main/reference/establish_updating_selection.html b/main/reference/establish_updating_selection.html index 6690f6c1d..5ab2ed830 100644 --- a/main/reference/establish_updating_selection.html +++ b/main/reference/establish_updating_selection.html @@ -50,6 +50,7 @@ id="dropdown-versions">Versions diff --git a/main/reference/get_scatterplotmatrix_stats.html b/main/reference/get_scatterplotmatrix_stats.html index 96431726e..9210cf15d 100644 --- a/main/reference/get_scatterplotmatrix_stats.html +++ b/main/reference/get_scatterplotmatrix_stats.html @@ -54,6 +54,7 @@ id="dropdown-versions">Versions diff --git a/main/reference/include_css_files.html b/main/reference/include_css_files.html index bf0573f08..e3364fe67 100644 --- a/main/reference/include_css_files.html +++ b/main/reference/include_css_files.html @@ -52,6 +52,7 @@ id="dropdown-versions">Versions diff --git a/main/reference/index.html b/main/reference/index.html index 544866088..1c5b09305 100644 --- a/main/reference/index.html +++ b/main/reference/index.html @@ -48,6 +48,7 @@ id="dropdown-versions">Versions diff --git a/main/reference/is_tab_active_js.html b/main/reference/is_tab_active_js.html index 7650967b8..6779fa8ad 100644 --- a/main/reference/is_tab_active_js.html +++ b/main/reference/is_tab_active_js.html @@ -48,6 +48,7 @@ id="dropdown-versions">Versions diff --git a/main/reference/plot_var_summary.html b/main/reference/plot_var_summary.html index b682583e7..7c0243b2b 100644 --- a/main/reference/plot_var_summary.html +++ b/main/reference/plot_var_summary.html @@ -48,6 +48,7 @@ id="dropdown-versions">Versions diff --git a/main/reference/rADAE.html b/main/reference/rADAE.html index 55aa3a962..c2d49835f 100644 --- a/main/reference/rADAE.html +++ b/main/reference/rADAE.html @@ -48,6 +48,7 @@ id="dropdown-versions">Versions diff --git a/main/reference/rADLB.html b/main/reference/rADLB.html index bc8f277bc..863b572a6 100644 --- a/main/reference/rADLB.html +++ b/main/reference/rADLB.html @@ -48,6 +48,7 @@ id="dropdown-versions">Versions diff --git a/main/reference/rADRS.html b/main/reference/rADRS.html index 46b97c28d..6a2e3528d 100644 --- a/main/reference/rADRS.html +++ b/main/reference/rADRS.html @@ -48,6 +48,7 @@ id="dropdown-versions">Versions diff --git a/main/reference/rADSL.html b/main/reference/rADSL.html index 3f5680f07..ca73bd075 100644 --- a/main/reference/rADSL.html +++ b/main/reference/rADSL.html @@ -48,6 +48,7 @@ id="dropdown-versions">Versions diff --git a/main/reference/rADTTE.html b/main/reference/rADTTE.html index af7b145cc..57d3198af 100644 --- a/main/reference/rADTTE.html +++ b/main/reference/rADTTE.html @@ -48,6 +48,7 @@ id="dropdown-versions">Versions diff --git a/main/reference/remove_outliers_from.html b/main/reference/remove_outliers_from.html index 48c54b35f..b3726a4f0 100644 --- a/main/reference/remove_outliers_from.html +++ b/main/reference/remove_outliers_from.html @@ -48,6 +48,7 @@ id="dropdown-versions">Versions diff --git a/main/reference/render_single_tab.html b/main/reference/render_single_tab.html index 01648dcf7..0c7cff5be 100644 --- a/main/reference/render_single_tab.html +++ b/main/reference/render_single_tab.html @@ -50,6 +50,7 @@ id="dropdown-versions">Versions diff --git a/main/reference/render_tab_header.html b/main/reference/render_tab_header.html index 0001bae95..cd944f2f1 100644 --- a/main/reference/render_tab_header.html +++ b/main/reference/render_tab_header.html @@ -48,6 +48,7 @@ id="dropdown-versions">Versions diff --git a/main/reference/render_tab_table.html b/main/reference/render_tab_table.html index 9dc7cc47f..e14d3f682 100644 --- a/main/reference/render_tab_table.html +++ b/main/reference/render_tab_table.html @@ -50,6 +50,7 @@ id="dropdown-versions">Versions diff --git a/main/reference/render_tabset_panel_content.html b/main/reference/render_tabset_panel_content.html index c61fb1774..97d59f7e9 100644 --- a/main/reference/render_tabset_panel_content.html +++ b/main/reference/render_tabset_panel_content.html @@ -48,6 +48,7 @@ id="dropdown-versions">Versions diff --git a/main/reference/shared_params.html b/main/reference/shared_params.html index 2a6e753db..8c2b11327 100644 --- a/main/reference/shared_params.html +++ b/main/reference/shared_params.html @@ -50,6 +50,7 @@ id="dropdown-versions">Versions diff --git a/main/reference/teal.modules.general.html b/main/reference/teal.modules.general.html index 45b9400a2..441625c5b 100644 --- a/main/reference/teal.modules.general.html +++ b/main/reference/teal.modules.general.html @@ -50,6 +50,7 @@ id="dropdown-versions">Versions diff --git a/main/reference/tm_a_pca.html b/main/reference/tm_a_pca.html index 66b59be45..026bd40c4 100644 --- a/main/reference/tm_a_pca.html +++ b/main/reference/tm_a_pca.html @@ -54,6 +54,7 @@ id="dropdown-versions">Versions diff --git a/main/reference/tm_a_regression.html b/main/reference/tm_a_regression.html index 89175840c..40ef476ed 100644 --- a/main/reference/tm_a_regression.html +++ b/main/reference/tm_a_regression.html @@ -54,6 +54,7 @@ id="dropdown-versions">Versions diff --git a/main/reference/tm_data_table.html b/main/reference/tm_data_table.html index fd887294e..3b964c6fa 100644 --- a/main/reference/tm_data_table.html +++ b/main/reference/tm_data_table.html @@ -52,6 +52,7 @@ id="dropdown-versions">Versions diff --git a/main/reference/tm_file_viewer.html b/main/reference/tm_file_viewer.html index 2a29ef3c3..9bc54d4ce 100644 --- a/main/reference/tm_file_viewer.html +++ b/main/reference/tm_file_viewer.html @@ -52,6 +52,7 @@ id="dropdown-versions">Versions diff --git a/main/reference/tm_front_page.html b/main/reference/tm_front_page.html index f94ae5398..2f2956f67 100644 --- a/main/reference/tm_front_page.html +++ b/main/reference/tm_front_page.html @@ -50,6 +50,7 @@ id="dropdown-versions">Versions diff --git a/main/reference/tm_g_association.html b/main/reference/tm_g_association.html index ba7f55ff1..d6be12a6b 100644 --- a/main/reference/tm_g_association.html +++ b/main/reference/tm_g_association.html @@ -52,6 +52,7 @@ id="dropdown-versions">Versions diff --git a/main/reference/tm_g_bivariate.html b/main/reference/tm_g_bivariate.html index 28bb53d1f..ba9f5f58a 100644 --- a/main/reference/tm_g_bivariate.html +++ b/main/reference/tm_g_bivariate.html @@ -50,6 +50,7 @@ id="dropdown-versions">Versions diff --git a/main/reference/tm_g_distribution.html b/main/reference/tm_g_distribution.html index f72a27dd1..422d12337 100644 --- a/main/reference/tm_g_distribution.html +++ b/main/reference/tm_g_distribution.html @@ -52,6 +52,7 @@ id="dropdown-versions">Versions diff --git a/main/reference/tm_g_response.html b/main/reference/tm_g_response.html index 6fb8d22a1..e05d0042f 100644 --- a/main/reference/tm_g_response.html +++ b/main/reference/tm_g_response.html @@ -58,6 +58,7 @@ id="dropdown-versions">Versions diff --git a/main/reference/tm_g_scatterplot.html b/main/reference/tm_g_scatterplot.html index bfa1cc3b2..462afce52 100644 --- a/main/reference/tm_g_scatterplot.html +++ b/main/reference/tm_g_scatterplot.html @@ -54,6 +54,7 @@ id="dropdown-versions">Versions diff --git a/main/reference/tm_g_scatterplotmatrix.html b/main/reference/tm_g_scatterplotmatrix.html index d95f7cf94..99b612fd9 100644 --- a/main/reference/tm_g_scatterplotmatrix.html +++ b/main/reference/tm_g_scatterplotmatrix.html @@ -52,6 +52,7 @@ id="dropdown-versions">Versions diff --git a/main/reference/tm_missing_data.html b/main/reference/tm_missing_data.html index 7994c23d1..15a31095c 100644 --- a/main/reference/tm_missing_data.html +++ b/main/reference/tm_missing_data.html @@ -54,6 +54,7 @@ id="dropdown-versions">Versions diff --git a/main/reference/tm_outliers.html b/main/reference/tm_outliers.html index 5be3a4d42..4012de2b6 100644 --- a/main/reference/tm_outliers.html +++ b/main/reference/tm_outliers.html @@ -52,6 +52,7 @@ id="dropdown-versions">Versions diff --git a/main/reference/tm_t_crosstable.html b/main/reference/tm_t_crosstable.html index 30f1da1f0..1759445e7 100644 --- a/main/reference/tm_t_crosstable.html +++ b/main/reference/tm_t_crosstable.html @@ -50,6 +50,7 @@ id="dropdown-versions">Versions diff --git a/main/reference/tm_variable_browser.html b/main/reference/tm_variable_browser.html index 625e2f9c0..550f96451 100644 --- a/main/reference/tm_variable_browser.html +++ b/main/reference/tm_variable_browser.html @@ -50,6 +50,7 @@ id="dropdown-versions">Versions diff --git a/main/reference/validate_input.html b/main/reference/validate_input.html index ea101b26a..2690a99ab 100644 --- a/main/reference/validate_input.html +++ b/main/reference/validate_input.html @@ -48,6 +48,7 @@ id="dropdown-versions">Versions diff --git a/main/reference/var_missings_info.html b/main/reference/var_missings_info.html index e8e14a4af..f74c03387 100644 --- a/main/reference/var_missings_info.html +++ b/main/reference/var_missings_info.html @@ -48,6 +48,7 @@ id="dropdown-versions">Versions diff --git a/main/reference/var_summary_table.html b/main/reference/var_summary_table.html index a515bfcf4..b886b20a0 100644 --- a/main/reference/var_summary_table.html +++ b/main/reference/var_summary_table.html @@ -52,6 +52,7 @@ id="dropdown-versions">Versions diff --git a/main/reference/variable_type_icons.html b/main/reference/variable_type_icons.html index 576a0e956..664e36ac6 100644 --- a/main/reference/variable_type_icons.html +++ b/main/reference/variable_type_icons.html @@ -48,6 +48,7 @@ id="dropdown-versions">Versions diff --git a/main/reference/varname_w_label.html b/main/reference/varname_w_label.html index 90e48004e..5ccab1ed4 100644 --- a/main/reference/varname_w_label.html +++ b/main/reference/varname_w_label.html @@ -48,6 +48,7 @@ id="dropdown-versions">Versions diff --git a/news/index.html b/news/index.html index 83202a69b..78f70d0e0 100644 --- a/news/index.html +++ b/news/index.html @@ -47,6 +47,7 @@ id="dropdown-versions">Versions diff --git a/pull_request_template.html b/pull_request_template.html index 8a87b83ec..e4fefbc8a 100644 --- a/pull_request_template.html +++ b/pull_request_template.html @@ -47,6 +47,7 @@ id="dropdown-versions">Versions diff --git a/reference/add_facet_labels.html b/reference/add_facet_labels.html index 91de320d8..0b165852c 100644 --- a/reference/add_facet_labels.html +++ b/reference/add_facet_labels.html @@ -47,6 +47,7 @@ id="dropdown-versions">Versions diff --git a/reference/call_fun_dots.html b/reference/call_fun_dots.html index da42ebc3d..f57f162dd 100644 --- a/reference/call_fun_dots.html +++ b/reference/call_fun_dots.html @@ -47,6 +47,7 @@ id="dropdown-versions">Versions diff --git a/reference/create_sparklines.html b/reference/create_sparklines.html index 90c87bf9f..4ef5efa59 100644 --- a/reference/create_sparklines.html +++ b/reference/create_sparklines.html @@ -55,6 +55,7 @@ id="dropdown-versions">Versions diff --git a/reference/establish_updating_selection.html b/reference/establish_updating_selection.html index 7f28864a2..95a22e383 100644 --- a/reference/establish_updating_selection.html +++ b/reference/establish_updating_selection.html @@ -49,6 +49,7 @@ id="dropdown-versions">Versions diff --git a/reference/extract_input.html b/reference/extract_input.html index a243acefe..4e51720a7 100644 --- a/reference/extract_input.html +++ b/reference/extract_input.html @@ -49,6 +49,7 @@ id="dropdown-versions">Versions diff --git a/reference/get_datanames_selected.html b/reference/get_datanames_selected.html index 073acff6f..41d0b1300 100644 --- a/reference/get_datanames_selected.html +++ b/reference/get_datanames_selected.html @@ -47,6 +47,7 @@ id="dropdown-versions">Versions diff --git a/reference/get_scatterplotmatrix_stats.html b/reference/get_scatterplotmatrix_stats.html index 363bbe96c..92942fc7c 100644 --- a/reference/get_scatterplotmatrix_stats.html +++ b/reference/get_scatterplotmatrix_stats.html @@ -51,6 +51,7 @@ id="dropdown-versions">Versions diff --git a/reference/get_var_description.html b/reference/get_var_description.html index 1d9017ae8..cd303f655 100644 --- a/reference/get_var_description.html +++ b/reference/get_var_description.html @@ -51,6 +51,7 @@ id="dropdown-versions">Versions diff --git a/reference/index.html b/reference/index.html index ea2c6d6a2..f0c52d85c 100644 --- a/reference/index.html +++ b/reference/index.html @@ -47,6 +47,7 @@ id="dropdown-versions">Versions diff --git a/reference/plot_var_summary.html b/reference/plot_var_summary.html index cae6ad741..7cbc22e87 100644 --- a/reference/plot_var_summary.html +++ b/reference/plot_var_summary.html @@ -47,6 +47,7 @@ id="dropdown-versions">Versions diff --git a/reference/remove_outliers_from.html b/reference/remove_outliers_from.html index d9d4da908..5bd7e1c43 100644 --- a/reference/remove_outliers_from.html +++ b/reference/remove_outliers_from.html @@ -47,6 +47,7 @@ id="dropdown-versions">Versions diff --git a/reference/render_single_tab.html b/reference/render_single_tab.html index 648e76a8f..8af5a0b18 100644 --- a/reference/render_single_tab.html +++ b/reference/render_single_tab.html @@ -49,6 +49,7 @@ id="dropdown-versions">Versions diff --git a/reference/render_tab_header.html b/reference/render_tab_header.html index bac81a413..76baeb047 100644 --- a/reference/render_tab_header.html +++ b/reference/render_tab_header.html @@ -47,6 +47,7 @@ id="dropdown-versions">Versions diff --git a/reference/render_tab_table.html b/reference/render_tab_table.html index 99f60df0c..2894655ca 100644 --- a/reference/render_tab_table.html +++ b/reference/render_tab_table.html @@ -49,6 +49,7 @@ id="dropdown-versions">Versions diff --git a/reference/render_tabset_panel_content.html b/reference/render_tabset_panel_content.html index 7a59da726..e553a8167 100644 --- a/reference/render_tabset_panel_content.html +++ b/reference/render_tabset_panel_content.html @@ -47,6 +47,7 @@ id="dropdown-versions">Versions diff --git a/reference/shared_params.html b/reference/shared_params.html index 5faceb534..68778f500 100644 --- a/reference/shared_params.html +++ b/reference/shared_params.html @@ -49,6 +49,7 @@ id="dropdown-versions">Versions diff --git a/reference/teal.modules.general.html b/reference/teal.modules.general.html index 0fd24d0ad..d84a47b8c 100644 --- a/reference/teal.modules.general.html +++ b/reference/teal.modules.general.html @@ -49,6 +49,7 @@ id="dropdown-versions">Versions diff --git a/reference/tm_a_pca.html b/reference/tm_a_pca.html index 7cec81aa1..90c4ce75e 100644 --- a/reference/tm_a_pca.html +++ b/reference/tm_a_pca.html @@ -47,6 +47,7 @@ id="dropdown-versions">Versions diff --git a/reference/tm_a_regression.html b/reference/tm_a_regression.html index 175c7d99d..2a4cebcd1 100644 --- a/reference/tm_a_regression.html +++ b/reference/tm_a_regression.html @@ -47,6 +47,7 @@ id="dropdown-versions">Versions diff --git a/reference/tm_data_table.html b/reference/tm_data_table.html index 9a000e323..0afc2f946 100644 --- a/reference/tm_data_table.html +++ b/reference/tm_data_table.html @@ -47,6 +47,7 @@ id="dropdown-versions">Versions diff --git a/reference/tm_file_viewer.html b/reference/tm_file_viewer.html index 265195b98..afc51a9e4 100644 --- a/reference/tm_file_viewer.html +++ b/reference/tm_file_viewer.html @@ -51,6 +51,7 @@ id="dropdown-versions">Versions diff --git a/reference/tm_front_page.html b/reference/tm_front_page.html index a188e6f60..006b34a9b 100644 --- a/reference/tm_front_page.html +++ b/reference/tm_front_page.html @@ -47,6 +47,7 @@ id="dropdown-versions">Versions diff --git a/reference/tm_g_association.html b/reference/tm_g_association.html index 8a31c6614..996089925 100644 --- a/reference/tm_g_association.html +++ b/reference/tm_g_association.html @@ -47,6 +47,7 @@ id="dropdown-versions">Versions diff --git a/reference/tm_g_bivariate.html b/reference/tm_g_bivariate.html index 92510b583..af86992e3 100644 --- a/reference/tm_g_bivariate.html +++ b/reference/tm_g_bivariate.html @@ -47,6 +47,7 @@ id="dropdown-versions">Versions diff --git a/reference/tm_g_distribution.html b/reference/tm_g_distribution.html index 92a985151..65e895c34 100644 --- a/reference/tm_g_distribution.html +++ b/reference/tm_g_distribution.html @@ -47,6 +47,7 @@ id="dropdown-versions">Versions diff --git a/reference/tm_g_response.html b/reference/tm_g_response.html index 2251de40b..28864d559 100644 --- a/reference/tm_g_response.html +++ b/reference/tm_g_response.html @@ -47,6 +47,7 @@ id="dropdown-versions">Versions diff --git a/reference/tm_g_scatterplot.html b/reference/tm_g_scatterplot.html index ab7f00bcc..680693a2a 100644 --- a/reference/tm_g_scatterplot.html +++ b/reference/tm_g_scatterplot.html @@ -47,6 +47,7 @@ id="dropdown-versions">Versions diff --git a/reference/tm_g_scatterplotmatrix.html b/reference/tm_g_scatterplotmatrix.html index 825dcde1e..0a7abcca5 100644 --- a/reference/tm_g_scatterplotmatrix.html +++ b/reference/tm_g_scatterplotmatrix.html @@ -49,6 +49,7 @@ id="dropdown-versions">Versions diff --git a/reference/tm_missing_data.html b/reference/tm_missing_data.html index 524fc72e1..0996a6724 100644 --- a/reference/tm_missing_data.html +++ b/reference/tm_missing_data.html @@ -47,6 +47,7 @@ id="dropdown-versions">Versions diff --git a/reference/tm_outliers.html b/reference/tm_outliers.html index f73ba5f8f..b25f60d52 100644 --- a/reference/tm_outliers.html +++ b/reference/tm_outliers.html @@ -47,6 +47,7 @@ id="dropdown-versions">Versions diff --git a/reference/tm_t_crosstable.html b/reference/tm_t_crosstable.html index 94aadc367..1be358f8a 100644 --- a/reference/tm_t_crosstable.html +++ b/reference/tm_t_crosstable.html @@ -47,6 +47,7 @@ id="dropdown-versions">Versions diff --git a/reference/tm_variable_browser.html b/reference/tm_variable_browser.html index 2169cba5b..d1d185b9d 100644 --- a/reference/tm_variable_browser.html +++ b/reference/tm_variable_browser.html @@ -49,6 +49,7 @@ id="dropdown-versions">Versions diff --git a/reference/validate_input.html b/reference/validate_input.html index 2eda5feca..162871087 100644 --- a/reference/validate_input.html +++ b/reference/validate_input.html @@ -47,6 +47,7 @@ id="dropdown-versions">Versions diff --git a/reference/var_missings_info.html b/reference/var_missings_info.html index 9daa9706d..ef8afab72 100644 --- a/reference/var_missings_info.html +++ b/reference/var_missings_info.html @@ -47,6 +47,7 @@ id="dropdown-versions">Versions diff --git a/reference/var_summary_table.html b/reference/var_summary_table.html index d853028da..e3bd12240 100644 --- a/reference/var_summary_table.html +++ b/reference/var_summary_table.html @@ -51,6 +51,7 @@ id="dropdown-versions">Versions diff --git a/reference/variable_type_icons.html b/reference/variable_type_icons.html index d5e198361..e55ab0357 100644 --- a/reference/variable_type_icons.html +++ b/reference/variable_type_icons.html @@ -47,6 +47,7 @@ id="dropdown-versions">Versions diff --git a/reference/varname_w_label.html b/reference/varname_w_label.html index 4a9a143f1..f2005c972 100644 --- a/reference/varname_w_label.html +++ b/reference/varname_w_label.html @@ -47,6 +47,7 @@ id="dropdown-versions">Versions diff --git a/release-candidate/404.html b/release-candidate/404.html index fe66f8e07..a94895227 100644 --- a/release-candidate/404.html +++ b/release-candidate/404.html @@ -64,6 +64,7 @@ id="dropdown-versions">Versions diff --git a/release-candidate/CODE_OF_CONDUCT.html b/release-candidate/CODE_OF_CONDUCT.html index f0f1c7834..d25757b33 100644 --- a/release-candidate/CODE_OF_CONDUCT.html +++ b/release-candidate/CODE_OF_CONDUCT.html @@ -48,6 +48,7 @@ id="dropdown-versions">Versions diff --git a/release-candidate/CONTRIBUTING.html b/release-candidate/CONTRIBUTING.html index ef7763945..f8936b67c 100644 --- a/release-candidate/CONTRIBUTING.html +++ b/release-candidate/CONTRIBUTING.html @@ -48,6 +48,7 @@ id="dropdown-versions">Versions diff --git a/release-candidate/LICENSE-text.html b/release-candidate/LICENSE-text.html index 17c4ad430..909d6cce5 100644 --- a/release-candidate/LICENSE-text.html +++ b/release-candidate/LICENSE-text.html @@ -48,6 +48,7 @@ id="dropdown-versions">Versions diff --git a/release-candidate/SECURITY.html b/release-candidate/SECURITY.html index 807f63156..17d53c277 100644 --- a/release-candidate/SECURITY.html +++ b/release-candidate/SECURITY.html @@ -48,6 +48,7 @@ id="dropdown-versions">Versions diff --git a/release-candidate/articles/images/app-teal-modules-general.png b/release-candidate/articles/images/app-teal-modules-general.png index e48bcc989..de4995f95 100644 Binary files a/release-candidate/articles/images/app-teal-modules-general.png and b/release-candidate/articles/images/app-teal-modules-general.png differ diff --git a/release-candidate/articles/images/app-using-association-plot.png b/release-candidate/articles/images/app-using-association-plot.png new file mode 100644 index 000000000..1d3bd30a0 Binary files /dev/null and b/release-candidate/articles/images/app-using-association-plot.png differ diff --git a/release-candidate/articles/images/app-using-bivariate-plot.png b/release-candidate/articles/images/app-using-bivariate-plot.png index 4b66e480c..8ff4ffcca 100644 Binary files a/release-candidate/articles/images/app-using-bivariate-plot.png and b/release-candidate/articles/images/app-using-bivariate-plot.png differ diff --git a/release-candidate/articles/images/app-using-cross-table.png b/release-candidate/articles/images/app-using-cross-table.png index 3dcc0f976..c82cd0eef 100644 Binary files a/release-candidate/articles/images/app-using-cross-table.png and b/release-candidate/articles/images/app-using-cross-table.png differ diff --git a/release-candidate/articles/images/app-using-data-table.png b/release-candidate/articles/images/app-using-data-table.png index 9baec5584..375da7330 100644 Binary files a/release-candidate/articles/images/app-using-data-table.png and b/release-candidate/articles/images/app-using-data-table.png differ diff --git a/release-candidate/articles/images/app-using-outliers-module.png b/release-candidate/articles/images/app-using-outliers-module.png index 998b9f0f3..7ed06ca8e 100644 Binary files a/release-candidate/articles/images/app-using-outliers-module.png and b/release-candidate/articles/images/app-using-outliers-module.png differ diff --git a/release-candidate/articles/images/app-using-regression-plots.png b/release-candidate/articles/images/app-using-regression-plots.png index e66bd0546..da57cbc9d 100644 Binary files a/release-candidate/articles/images/app-using-regression-plots.png and b/release-candidate/articles/images/app-using-regression-plots.png differ diff --git a/release-candidate/articles/images/app-using-response-plot.png b/release-candidate/articles/images/app-using-response-plot.png index d53fe5740..797e2ae33 100644 Binary files a/release-candidate/articles/images/app-using-response-plot.png and b/release-candidate/articles/images/app-using-response-plot.png differ diff --git a/release-candidate/articles/images/app-using-scatterplot-matrix.png b/release-candidate/articles/images/app-using-scatterplot-matrix.png index 703677109..afb07b49a 100644 Binary files a/release-candidate/articles/images/app-using-scatterplot-matrix.png and b/release-candidate/articles/images/app-using-scatterplot-matrix.png differ diff --git a/release-candidate/articles/images/app-using-scatterplot.png b/release-candidate/articles/images/app-using-scatterplot.png index b2e4d92b3..3a665e46a 100644 Binary files a/release-candidate/articles/images/app-using-scatterplot.png and b/release-candidate/articles/images/app-using-scatterplot.png differ diff --git a/release-candidate/articles/index.html b/release-candidate/articles/index.html index 49f9723a5..e606ad9e8 100644 --- a/release-candidate/articles/index.html +++ b/release-candidate/articles/index.html @@ -48,6 +48,7 @@ id="dropdown-versions">Versions diff --git a/release-candidate/articles/teal-modules-general.html b/release-candidate/articles/teal-modules-general.html index 34bc44b75..b9d57a6ee 100644 --- a/release-candidate/articles/teal-modules-general.html +++ b/release-candidate/articles/teal-modules-general.html @@ -66,6 +66,7 @@ id="dropdown-versions">Versions diff --git a/release-candidate/articles/using-association-plot.html b/release-candidate/articles/using-association-plot.html index fdab83b00..c5bd76088 100644 --- a/release-candidate/articles/using-association-plot.html +++ b/release-candidate/articles/using-association-plot.html @@ -66,6 +66,7 @@ id="dropdown-versions">Versions @@ -418,7 +419,7 @@
shinyApp(app$ui, app$server, options = list(height = 1024, width = 1024))
-
+
diff --git a/release-candidate/articles/using-cross-table.html b/release-candidate/articles/using-cross-table.html
index 0cc9b36db..85e1d965c 100644
--- a/release-candidate/articles/using-cross-table.html
+++ b/release-candidate/articles/using-cross-table.html
@@ -66,6 +66,7 @@
id="dropdown-versions">Versions
diff --git a/release-candidate/articles/using-data-table.html b/release-candidate/articles/using-data-table.html
index 8edda77e4..f5ef01a95 100644
--- a/release-candidate/articles/using-data-table.html
+++ b/release-candidate/articles/using-data-table.html
@@ -66,6 +66,7 @@
id="dropdown-versions">Versions
diff --git a/release-candidate/articles/using-outliers-module.html b/release-candidate/articles/using-outliers-module.html
index 27bd8dd04..b69e11054 100644
--- a/release-candidate/articles/using-outliers-module.html
+++ b/release-candidate/articles/using-outliers-module.html
@@ -66,6 +66,7 @@
id="dropdown-versions">Versions
diff --git a/release-candidate/articles/using-regression-plots.html b/release-candidate/articles/using-regression-plots.html
index 3adcc194b..6373ec855 100644
--- a/release-candidate/articles/using-regression-plots.html
+++ b/release-candidate/articles/using-regression-plots.html
@@ -66,6 +66,7 @@
id="dropdown-versions">Versions
diff --git a/release-candidate/articles/using-response-plot.html b/release-candidate/articles/using-response-plot.html
index e9993f3fd..fe91019aa 100644
--- a/release-candidate/articles/using-response-plot.html
+++ b/release-candidate/articles/using-response-plot.html
@@ -66,6 +66,7 @@
id="dropdown-versions">Versions
diff --git a/release-candidate/articles/using-scatterplot-matrix.html b/release-candidate/articles/using-scatterplot-matrix.html
index 2b46d21d1..956c65aec 100644
--- a/release-candidate/articles/using-scatterplot-matrix.html
+++ b/release-candidate/articles/using-scatterplot-matrix.html
@@ -66,6 +66,7 @@
id="dropdown-versions">Versions
diff --git a/release-candidate/articles/using-scatterplot.html b/release-candidate/articles/using-scatterplot.html
index 795291f89..7b5f2853a 100644
--- a/release-candidate/articles/using-scatterplot.html
+++ b/release-candidate/articles/using-scatterplot.html
@@ -66,6 +66,7 @@
id="dropdown-versions">Versions
diff --git a/release-candidate/authors.html b/release-candidate/authors.html
index 3c34ad730..4612e866b 100644
--- a/release-candidate/authors.html
+++ b/release-candidate/authors.html
@@ -48,6 +48,7 @@
id="dropdown-versions">Versions
diff --git a/release-candidate/coverage-report/index.html b/release-candidate/coverage-report/index.html
deleted file mode 100644
index 24c676663..000000000
--- a/release-candidate/coverage-report/index.html
+++ /dev/null
@@ -1,88496 +0,0 @@
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-1 | -- |
- #' `teal` module: Distribution analysis- |
-
2 | -- |
- #'- |
-
3 | -- |
- #' Module is designed to explore the distribution of a single variable within a given dataset.- |
-
4 | -- |
- #' It offers several tools, such as histograms, Q-Q plots, and various statistical tests to- |
-
5 | -- |
- #' visually and statistically analyze the variable's distribution.- |
-
6 | -- |
- #'- |
-
7 | -- |
- #' @inheritParams teal::module- |
-
8 | -- |
- #' @inheritParams teal.widgets::standard_layout- |
-
9 | -- |
- #' @inheritParams shared_params- |
-
10 | -- |
- #'- |
-
11 | -- |
- #' @param dist_var (`data_extract_spec` or `list` of multiple `data_extract_spec`)- |
-
12 | -- |
- #' Variable(s) for which the distribution will be analyzed.- |
-
13 | -- |
- #' @param strata_var (`data_extract_spec` or `list` of multiple `data_extract_spec`)- |
-
14 | -- |
- #' Categorical variable used to split the distribution analysis.- |
-
15 | -- |
- #' @param group_var (`data_extract_spec` or `list` of multiple `data_extract_spec`)- |
-
16 | -- |
- #' Variable used for faceting plot into multiple panels.- |
-
17 | -- |
- #' @param freq (`logical`) optional, whether to display frequency (`TRUE`) or density (`FALSE`).- |
-
18 | -- |
- #' Defaults to density (`FALSE`).- |
-
19 | -- |
- #' @param bins (`integer(1)` or `integer(3)`) optional, specifies the number of bins for the histogram.- |
-
20 | -- |
- #' - When the length of `bins` is one: The histogram bins will have a fixed size based on the `bins` provided.- |
-
21 | -- |
- #' - When the length of `bins` is three: The histogram bins are dynamically adjusted based on vector of `value`, `min`,- |
-
22 | -- |
- #' and `max`.- |
-
23 | -- |
- #' Defaults to `c(30L, 1L, 100L)`.- |
-
24 | -- |
- #'- |
-
25 | -- |
- #' @templateVar ggnames "Histogram", "QQplot"- |
-
26 | -- |
- #' @template ggplot2_args_multi- |
-
27 | -- |
- #'- |
-
28 | -- |
- #' @inherit shared_params return- |
-
29 | -- |
- #'- |
-
30 | -- |
- #' @examples- |
-
31 | -- |
- #' library(teal.widgets)- |
-
32 | -- |
- #'- |
-
33 | -- |
- #' # general data example- |
-
34 | -- |
- #' data <- teal_data()- |
-
35 | -- |
- #' data <- within(data, {- |
-
36 | -- |
- #' iris <- iris- |
-
37 | -- |
- #' })- |
-
38 | -- |
- #' datanames(data) <- "iris"- |
-
39 | -- |
- #'- |
-
40 | -- |
- #' app <- init(- |
-
41 | -- |
- #' data = data,- |
-
42 | -- |
- #' modules = list(- |
-
43 | -- |
- #' tm_g_distribution(- |
-
44 | -- |
- #' dist_var = data_extract_spec(- |
-
45 | -- |
- #' dataname = "iris",- |
-
46 | -- |
- #' select = select_spec(variable_choices("iris"), "Petal.Length")- |
-
47 | -- |
- #' ),- |
-
48 | -- |
- #' ggplot2_args = ggplot2_args(- |
-
49 | -- |
- #' labs = list(subtitle = "Plot generated by Distribution Module")- |
-
50 | -- |
- #' )- |
-
51 | -- |
- #' )- |
-
52 | -- |
- #' )- |
-
53 | -- |
- #' )- |
-
54 | -- |
- #' if (interactive()) {- |
-
55 | -- |
- #' shinyApp(app$ui, app$server)- |
-
56 | -- |
- #' }- |
-
57 | -- |
- #'- |
-
58 | -- |
- #' # CDISC data example- |
-
59 | -- |
- #' data <- teal_data()- |
-
60 | -- |
- #' data <- within(data, {- |
-
61 | -- |
- #' ADSL <- rADSL- |
-
62 | -- |
- #' })- |
-
63 | -- |
- #' datanames(data) <- c("ADSL")- |
-
64 | -- |
- #' join_keys(data) <- default_cdisc_join_keys[datanames(data)]- |
-
65 | -- |
- #'- |
-
66 | -- |
- #' vars1 <- choices_selected(- |
-
67 | -- |
- #' variable_choices(data[["ADSL"]], c("ARM", "COUNTRY", "SEX")),- |
-
68 | -- |
- #' selected = NULL- |
-
69 | -- |
- #' )- |
-
70 | -- |
- #'- |
-
71 | -- |
- #' app <- init(- |
-
72 | -- |
- #' data = data,- |
-
73 | -- |
- #' modules = modules(- |
-
74 | -- |
- #' tm_g_distribution(- |
-
75 | -- |
- #' dist_var = data_extract_spec(- |
-
76 | -- |
- #' dataname = "ADSL",- |
-
77 | -- |
- #' select = select_spec(- |
-
78 | -- |
- #' choices = variable_choices(data[["ADSL"]], c("AGE", "BMRKR1")),- |
-
79 | -- |
- #' selected = "BMRKR1",- |
-
80 | -- |
- #' multiple = FALSE,- |
-
81 | -- |
- #' fixed = FALSE- |
-
82 | -- |
- #' )- |
-
83 | -- |
- #' ),- |
-
84 | -- |
- #' strata_var = data_extract_spec(- |
-
85 | -- |
- #' dataname = "ADSL",- |
-
86 | -- |
- #' filter = filter_spec(- |
-
87 | -- |
- #' vars = vars1,- |
-
88 | -- |
- #' multiple = TRUE- |
-
89 | -- |
- #' )- |
-
90 | -- |
- #' ),- |
-
91 | -- |
- #' group_var = data_extract_spec(- |
-
92 | -- |
- #' dataname = "ADSL",- |
-
93 | -- |
- #' filter = filter_spec(- |
-
94 | -- |
- #' vars = vars1,- |
-
95 | -- |
- #' multiple = TRUE- |
-
96 | -- |
- #' )- |
-
97 | -- |
- #' ),- |
-
98 | -- |
- #' ggplot2_args = ggplot2_args(- |
-
99 | -- |
- #' labs = list(subtitle = "Plot generated by Distribution Module")- |
-
100 | -- |
- #' )- |
-
101 | -- |
- #' )- |
-
102 | -- |
- #' )- |
-
103 | -- |
- #' )- |
-
104 | -- |
- #' if (interactive()) {- |
-
105 | -- |
- #' shinyApp(app$ui, app$server)- |
-
106 | -- |
- #' }- |
-
107 | -- |
- #'- |
-
108 | -- |
- #' @export- |
-
109 | -- |
- #'- |
-
110 | -- |
- tm_g_distribution <- function(label = "Distribution Module",- |
-
111 | -- |
- dist_var,- |
-
112 | -- |
- strata_var = NULL,- |
-
113 | -- |
- group_var = NULL,- |
-
114 | -- |
- freq = FALSE,- |
-
115 | -- |
- ggtheme = c("gray", "bw", "linedraw", "light", "dark", "minimal", "classic", "void"),- |
-
116 | -- |
- ggplot2_args = teal.widgets::ggplot2_args(),- |
-
117 | -- |
- bins = c(30L, 1L, 100L),- |
-
118 | -- |
- plot_height = c(600, 200, 2000),- |
-
119 | -- |
- plot_width = NULL,- |
-
120 | -- |
- pre_output = NULL,- |
-
121 | -- |
- post_output = NULL) {- |
-
122 | -! | -
- logger::log_info("Initializing tm_g_distribution")- |
-
123 | -- | - - | -
124 | -- |
- # Requires Suggested packages- |
-
125 | -! | -
- extra_packages <- c("ggpmisc", "ggpp", "goftest", "MASS", "broom")- |
-
126 | -! | -
- missing_packages <- Filter(function(x) !requireNamespace(x, quietly = TRUE), extra_packages)- |
-
127 | -! | -
- if (length(missing_packages) > 0L) {- |
-
128 | -! | -
- stop(sprintf(- |
-
129 | -! | -
- "Cannot load package(s): %s.\nInstall or restart your session.",- |
-
130 | -! | -
- toString(missing_packages)- |
-
131 | -- |
- ))- |
-
132 | -- |
- }- |
-
133 | -- | - - | -
134 | -- |
- # Normalize the parameters- |
-
135 | -! | -
- if (inherits(dist_var, "data_extract_spec")) dist_var <- list(dist_var)- |
-
136 | -! | -
- if (inherits(strata_var, "data_extract_spec")) strata_var <- list(strata_var)- |
-
137 | -! | -
- if (inherits(group_var, "data_extract_spec")) group_var <- list(group_var)- |
-
138 | -! | -
- if (inherits(ggplot2_args, "ggplot2_args")) ggplot2_args <- list(default = ggplot2_args)- |
-
139 | -- | - - | -
140 | -- |
- # Start of assertions- |
-
141 | -! | -
- checkmate::assert_string(label)- |
-
142 | -- | - - | -
143 | -! | -
- checkmate::assert_list(dist_var, "data_extract_spec")- |
-
144 | -! | -
- checkmate::assert_false(dist_var[[1L]]$select$multiple)- |
-
145 | -- | - - | -
146 | -! | -
- checkmate::assert_list(strata_var, types = "data_extract_spec", null.ok = TRUE)- |
-
147 | -! | -
- checkmate::assert_list(group_var, types = "data_extract_spec", null.ok = TRUE)- |
-
148 | -! | -
- checkmate::assert_flag(freq)- |
-
149 | -! | -
- ggtheme <- match.arg(ggtheme)- |
-
150 | -- | - - | -
151 | -! | -
- plot_choices <- c("Histogram", "QQplot")- |
-
152 | -! | -
- checkmate::assert_list(ggplot2_args, types = "ggplot2_args")- |
-
153 | -! | -
- checkmate::assert_subset(names(ggplot2_args), c("default", plot_choices))- |
-
154 | -- | - - | -
155 | -! | -
- if (length(bins) == 1) {- |
-
156 | -! | -
- checkmate::assert_numeric(bins, any.missing = FALSE, lower = 1)- |
-
157 | -- |
- } else {- |
-
158 | -! | -
- checkmate::assert_numeric(bins, len = 3, any.missing = FALSE, lower = 1)- |
-
159 | -! | -
- checkmate::assert_numeric(bins[1], lower = bins[2], upper = bins[3], .var.name = "bins")- |
-
160 | -- |
- }- |
-
161 | -- | - - | -
162 | -! | -
- checkmate::assert_numeric(plot_height, len = 3, any.missing = FALSE, finite = TRUE)- |
-
163 | -! | -
- checkmate::assert_numeric(plot_height[1], lower = plot_height[2], upper = plot_height[3], .var.name = "plot_height")- |
-
164 | -! | -
- checkmate::assert_numeric(plot_width, len = 3, any.missing = FALSE, null.ok = TRUE, finite = TRUE)- |
-
165 | -! | -
- checkmate::assert_numeric(- |
-
166 | -! | -
- plot_width[1],- |
-
167 | -! | -
- lower = plot_width[2], upper = plot_width[3], null.ok = TRUE, .var.name = "plot_width"- |
-
168 | -- |
- )- |
-
169 | -- | - - | -
170 | -! | -
- checkmate::assert_multi_class(pre_output, c("shiny.tag", "shiny.tag.list", "html"), null.ok = TRUE)- |
-
171 | -! | -
- checkmate::assert_multi_class(post_output, c("shiny.tag", "shiny.tag.list", "html"), null.ok = TRUE)- |
-
172 | -- |
- # End of assertions- |
-
173 | -- | - - | -
174 | -- |
- # Make UI args- |
-
175 | -! | -
- args <- as.list(environment())- |
-
176 | -- | - - | -
177 | -! | -
- data_extract_list <- list(- |
-
178 | -! | -
- dist_var = dist_var,- |
-
179 | -! | -
- strata_var = strata_var,- |
-
180 | -! | -
- group_var = group_var- |
-
181 | -- |
- )- |
-
182 | -- | - - | -
183 | -! | -
- module(- |
-
184 | -! | -
- label = label,- |
-
185 | -! | -
- server = srv_distribution,- |
-
186 | -! | -
- server_args = c(- |
-
187 | -! | -
- data_extract_list,- |
-
188 | -! | -
- list(plot_height = plot_height, plot_width = plot_width, ggplot2_args = ggplot2_args)- |
-
189 | -- |
- ),- |
-
190 | -! | -
- ui = ui_distribution,- |
-
191 | -! | -
- ui_args = args,- |
-
192 | -! | -
- datanames = teal.transform::get_extract_datanames(data_extract_list)- |
-
193 | -- |
- )- |
-
194 | -- |
- }- |
-
195 | -- | - - | -
196 | -- |
- # UI function for the distribution module- |
-
197 | -- |
- ui_distribution <- function(id, ...) {- |
-
198 | -! | -
- args <- list(...)- |
-
199 | -! | -
- ns <- NS(id)- |
-
200 | -! | -
- is_single_dataset_value <- teal.transform::is_single_dataset(args$dist_var, args$strata_var, args$group_var)- |
-
201 | -- | - - | -
202 | -! | -
- teal.widgets::standard_layout(- |
-
203 | -! | -
- output = teal.widgets::white_small_well(- |
-
204 | -! | -
- tabsetPanel(- |
-
205 | -! | -
- id = ns("tabs"),- |
-
206 | -! | -
- tabPanel("Histogram", teal.widgets::plot_with_settings_ui(id = ns("hist_plot"))),- |
-
207 | -! | -
- tabPanel("QQplot", teal.widgets::plot_with_settings_ui(id = ns("qq_plot")))- |
-
208 | -- |
- ),- |
-
209 | -! | -
- h3("Statistics Table"),- |
-
210 | -! | -
- DT::dataTableOutput(ns("summary_table")),- |
-
211 | -! | -
- h3("Tests"),- |
-
212 | -! | -
- DT::dataTableOutput(ns("t_stats"))- |
-
213 | -- |
- ),- |
-
214 | -! | -
- encoding = div(- |
-
215 | -- |
- ### Reporter- |
-
216 | -! | -
- teal.reporter::simple_reporter_ui(ns("simple_reporter")),- |
-
217 | -- |
- ###- |
-
218 | -! | -
- tags$label("Encodings", class = "text-primary"),- |
-
219 | -! | -
- teal.transform::datanames_input(args[c("dist_var", "strata_var")]),- |
-
220 | -! | -
- teal.transform::data_extract_ui(- |
-
221 | -! | -
- id = ns("dist_i"),- |
-
222 | -! | -
- label = "Variable",- |
-
223 | -! | -
- data_extract_spec = args$dist_var,- |
-
224 | -! | -
- is_single_dataset = is_single_dataset_value- |
-
225 | -- |
- ),- |
-
226 | -! | -
- if (!is.null(args$group_var)) {- |
-
227 | -! | -
- tagList(- |
-
228 | -! | -
- teal.transform::data_extract_ui(- |
-
229 | -! | -
- id = ns("group_i"),- |
-
230 | -! | -
- label = "Group by",- |
-
231 | -! | -
- data_extract_spec = args$group_var,- |
-
232 | -! | -
- is_single_dataset = is_single_dataset_value- |
-
233 | -- |
- ),- |
-
234 | -! | -
- uiOutput(ns("scales_types_ui"))- |
-
235 | -- |
- )- |
-
236 | -- |
- },- |
-
237 | -! | -
- if (!is.null(args$strata_var)) {- |
-
238 | -! | -
- teal.transform::data_extract_ui(- |
-
239 | -! | -
- id = ns("strata_i"),- |
-
240 | -! | -
- label = "Stratify by",- |
-
241 | -! | -
- data_extract_spec = args$strata_var,- |
-
242 | -! | -
- is_single_dataset = is_single_dataset_value- |
-
243 | -- |
- )- |
-
244 | -- |
- },- |
-
245 | -! | -
- teal.widgets::panel_group(- |
-
246 | -! | -
- conditionalPanel(- |
-
247 | -! | -
- condition = paste0("input['", ns("tabs"), "'] == 'Histogram'"),- |
-
248 | -! | -
- teal.widgets::panel_item(- |
-
249 | -! | -
- "Histogram",- |
-
250 | -! | -
- teal.widgets::optionalSliderInputValMinMax(ns("bins"), "Bins", args$bins, ticks = FALSE, step = 1),- |
-
251 | -! | -
- shinyWidgets::prettyRadioButtons(- |
-
252 | -! | -
- ns("main_type"),- |
-
253 | -! | -
- label = "Plot Type:",- |
-
254 | -! | -
- choices = c("Density", "Frequency"),- |
-
255 | -! | -
- selected = if (!args$freq) "Density" else "Frequency",- |
-
256 | -! | -
- bigger = FALSE,- |
-
257 | -! | -
- inline = TRUE- |
-
258 | -- |
- ),- |
-
259 | -! | -
- checkboxInput(ns("add_dens"), label = "Overlay Density", value = TRUE),- |
-
260 | -! | -
- collapsed = FALSE- |
-
261 | -- |
- )- |
-
262 | -- |
- ),- |
-
263 | -! | -
- conditionalPanel(- |
-
264 | -! | -
- condition = paste0("input['", ns("tabs"), "'] == 'QQplot'"),- |
-
265 | -! | -
- teal.widgets::panel_item(- |
-
266 | -! | -
- "QQ Plot",- |
-
267 | -! | -
- checkboxInput(ns("qq_line"), label = "Add diagonal line(s)", TRUE),- |
-
268 | -! | -
- collapsed = FALSE- |
-
269 | -- |
- )- |
-
270 | -- |
- ),- |
-
271 | -! | -
- conditionalPanel(- |
-
272 | -! | -
- condition = paste0("input['", ns("main_type"), "'] == 'Density'"),- |
-
273 | -! | -
- teal.widgets::panel_item(- |
-
274 | -! | -
- "Theoretical Distribution",- |
-
275 | -! | -
- teal.widgets::optionalSelectInput(- |
-
276 | -! | -
- ns("t_dist"),- |
-
277 | -! | -
- div(- |
-
278 | -! | -
- class = "teal-tooltip",- |
-
279 | -! | -
- tagList(- |
-
280 | -! | -
- "Distribution:",- |
-
281 | -! | -
- icon("circle-info"),- |
-
282 | -! | -
- span(- |
-
283 | -! | -
- class = "tooltiptext",- |
-
284 | -! | -
- "Default parameters are optimized with MASS::fitdistr function."- |
-
285 | -- |
- )- |
-
286 | -- |
- )- |
-
287 | -- |
- ),- |
-
288 | -! | -
- choices = c("normal", "lognormal", "gamma", "unif"),- |
-
289 | -! | -
- selected = NULL,- |
-
290 | -! | -
- multiple = FALSE- |
-
291 | -- |
- ),- |
-
292 | -! | -
- numericInput(ns("dist_param1"), label = "param1", value = NULL),- |
-
293 | -! | -
- numericInput(ns("dist_param2"), label = "param2", value = NULL),- |
-
294 | -! | -
- span(actionButton(ns("params_reset"), "Reset params")),- |
-
295 | -! | -
- collapsed = FALSE- |
-
296 | -- |
- )- |
-
297 | -- |
- )- |
-
298 | -- |
- ),- |
-
299 | -! | -
- teal.widgets::panel_item(- |
-
300 | -! | -
- "Tests",- |
-
301 | -! | -
- teal.widgets::optionalSelectInput(- |
-
302 | -! | -
- ns("dist_tests"),- |
-
303 | -! | -
- "Tests:",- |
-
304 | -! | -
- choices = c(- |
-
305 | -! | -
- "Shapiro-Wilk",- |
-
306 | -! | -
- if (!is.null(args$strata_var)) "t-test (two-samples, not paired)",- |
-
307 | -! | -
- if (!is.null(args$strata_var)) "one-way ANOVA",- |
-
308 | -! | -
- if (!is.null(args$strata_var)) "Fligner-Killeen",- |
-
309 | -! | -
- if (!is.null(args$strata_var)) "F-test",- |
-
310 | -! | -
- "Kolmogorov-Smirnov (one-sample)",- |
-
311 | -! | -
- "Anderson-Darling (one-sample)",- |
-
312 | -! | -
- "Cramer-von Mises (one-sample)",- |
-
313 | -! | -
- if (!is.null(args$strata_var)) "Kolmogorov-Smirnov (two-samples)"- |
-
314 | -- |
- ),- |
-
315 | -! | -
- selected = NULL- |
-
316 | -- |
- )- |
-
317 | -- |
- ),- |
-
318 | -! | -
- teal.widgets::panel_item(- |
-
319 | -! | -
- "Statistics Table",- |
-
320 | -! | -
- sliderInput(ns("roundn"), "Round to n digits", min = 0, max = 10, value = 2)- |
-
321 | -- |
- ),- |
-
322 | -! | -
- teal.widgets::panel_item(- |
-
323 | -! | -
- title = "Plot settings",- |
-
324 | -! | -
- selectInput(- |
-
325 | -! | -
- inputId = ns("ggtheme"),- |
-
326 | -! | -
- label = "Theme (by ggplot):",- |
-
327 | -! | -
- choices = ggplot_themes,- |
-
328 | -! | -
- selected = args$ggtheme,- |
-
329 | -! | -
- multiple = FALSE- |
-
330 | -- |
- )- |
-
331 | -- |
- )- |
-
332 | -- |
- ),- |
-
333 | -! | -
- forms = tagList(- |
-
334 | -! | -
- teal.widgets::verbatim_popup_ui(ns("warning"), "Show Warnings"),- |
-
335 | -! | -
- teal.widgets::verbatim_popup_ui(ns("rcode"), "Show R code")- |
-
336 | -- |
- ),- |
-
337 | -! | -
- pre_output = args$pre_output,- |
-
338 | -! | -
- post_output = args$post_output- |
-
339 | -- |
- )- |
-
340 | -- |
- }- |
-
341 | -- | - - | -
342 | -- |
- # Server function for the distribution module- |
-
343 | -- |
- srv_distribution <- function(id,- |
-
344 | -- |
- data,- |
-
345 | -- |
- reporter,- |
-
346 | -- |
- filter_panel_api,- |
-
347 | -- |
- dist_var,- |
-
348 | -- |
- strata_var,- |
-
349 | -- |
- group_var,- |
-
350 | -- |
- plot_height,- |
-
351 | -- |
- plot_width,- |
-
352 | -- |
- ggplot2_args) {- |
-
353 | -! | -
- with_reporter <- !missing(reporter) && inherits(reporter, "Reporter")- |
-
354 | -! | -
- with_filter <- !missing(filter_panel_api) && inherits(filter_panel_api, "FilterPanelAPI")- |
-
355 | -! | -
- checkmate::assert_class(data, "reactive")- |
-
356 | -! | -
- checkmate::assert_class(isolate(data()), "teal_data")- |
-
357 | -! | -
- moduleServer(id, function(input, output, session) {- |
-
358 | -! | -
- rule_req <- function(value) {- |
-
359 | -! | -
- if (isTRUE(input$dist_tests %in% c(- |
-
360 | -! | -
- "Fligner-Killeen",- |
-
361 | -! | -
- "t-test (two-samples, not paired)",- |
-
362 | -! | -
- "F-test",- |
-
363 | -! | -
- "Kolmogorov-Smirnov (two-samples)",- |
-
364 | -! | -
- "one-way ANOVA"- |
-
365 | -- |
- ))) {- |
-
366 | -! | -
- if (!shinyvalidate::input_provided(value)) {- |
-
367 | -! | -
- "Please select stratify variable."- |
-
368 | -- |
- }- |
-
369 | -- |
- }- |
-
370 | -- |
- }- |
-
371 | -! | -
- rule_dupl <- function(...) {- |
-
372 | -! | -
- if (identical(input$dist_tests, "Fligner-Killeen")) {- |
-
373 | -! | -
- strata <- selector_list()$strata_i()$select- |
-
374 | -! | -
- group <- selector_list()$group_i()$select- |
-
375 | -! | -
- if (isTRUE(strata == group)) {- |
-
376 | -! | -
- "Please select different variables for strata and group."- |
-
377 | -- |
- }- |
-
378 | -- |
- }- |
-
379 | -- |
- }- |
-
380 | -- | - - | -
381 | -! | -
- selector_list <- teal.transform::data_extract_multiple_srv(- |
-
382 | -! | -
- data_extract = list(- |
-
383 | -! | -
- dist_i = dist_var,- |
-
384 | -! | -
- strata_i = strata_var,- |
-
385 | -! | -
- group_i = group_var- |
-
386 | -- |
- ),- |
-
387 | -! | -
- data,- |
-
388 | -! | -
- select_validation_rule = list(- |
-
389 | -! | -
- dist_i = shinyvalidate::sv_required("Please select a variable")- |
-
390 | -- |
- ),- |
-
391 | -! | -
- filter_validation_rule = list(- |
-
392 | -! | -
- strata_i = shinyvalidate::compose_rules(- |
-
393 | -! | -
- rule_req,- |
-
394 | -! | -
- rule_dupl- |
-
395 | -- |
- ),- |
-
396 | -! | -
- group_i = rule_dupl- |
-
397 | -- |
- )- |
-
398 | -- |
- )- |
-
399 | -- | - - | -
400 | -! | -
- iv_r <- reactive({- |
-
401 | -! | -
- iv <- shinyvalidate::InputValidator$new()- |
-
402 | -! | -
- teal.transform::compose_and_enable_validators(iv, selector_list, validator_names = "dist_i")- |
-
403 | -- |
- })- |
-
404 | -- | - - | -
405 | -! | -
- iv_r_dist <- reactive({- |
-
406 | -! | -
- iv <- shinyvalidate::InputValidator$new()- |
-
407 | -! | -
- teal.transform::compose_and_enable_validators(- |
-
408 | -! | -
- iv, selector_list,- |
-
409 | -! | -
- validator_names = c("strata_i", "group_i")- |
-
410 | -- |
- )- |
-
411 | -- |
- })- |
-
412 | -! | -
- rule_dist_1 <- function(value) {- |
-
413 | -! | -
- if (!is.null(input$t_dist)) {- |
-
414 | -! | -
- switch(input$t_dist,- |
-
415 | -! | -
- "normal" = if (!shinyvalidate::input_provided(value)) "mean is required",- |
-
416 | -! | -
- "lognormal" = if (!shinyvalidate::input_provided(value)) "meanlog is required",- |
-
417 | -! | -
- "gamma" = {- |
-
418 | -! | -
- if (!shinyvalidate::input_provided(value)) "shape is required" else if (value <= 0) "shape must be positive"- |
-
419 | -- |
- },- |
-
420 | -! | -
- "unif" = NULL- |
-
421 | -- |
- )- |
-
422 | -- |
- }- |
-
423 | -- |
- }- |
-
424 | -! | -
- rule_dist_2 <- function(value) {- |
-
425 | -! | -
- if (!is.null(input$t_dist)) {- |
-
426 | -! | -
- switch(input$t_dist,- |
-
427 | -! | -
- "normal" = {- |
-
428 | -! | -
- if (!shinyvalidate::input_provided(value)) {- |
-
429 | -! | -
- "sd is required"- |
-
430 | -! | -
- } else if (value < 0) {- |
-
431 | -! | -
- "sd must be non-negative"- |
-
432 | -- |
- }- |
-
433 | -- |
- },- |
-
434 | -! | -
- "lognormal" = {- |
-
435 | -! | -
- if (!shinyvalidate::input_provided(value)) {- |
-
436 | -! | -
- "sdlog is required"- |
-
437 | -! | -
- } else if (value < 0) {- |
-
438 | -! | -
- "sdlog must be non-negative"- |
-
439 | -- |
- }- |
-
440 | -- |
- },- |
-
441 | -! | -
- "gamma" = {- |
-
442 | -! | -
- if (!shinyvalidate::input_provided(value)) {- |
-
443 | -! | -
- "rate is required"- |
-
444 | -! | -
- } else if (value <= 0) {- |
-
445 | -! | -
- "rate must be positive"- |
-
446 | -- |
- }- |
-
447 | -- |
- },- |
-
448 | -! | -
- "unif" = NULL- |
-
449 | -- |
- )- |
-
450 | -- |
- }- |
-
451 | -- |
- }- |
-
452 | -! | -
- rule_dist <- function(value) {- |
-
453 | -! | -
- if (isTRUE(input$tabs == "QQplot" ||- |
-
454 | -! | -
- input$dist_tests %in% c(- |
-
455 | -! | -
- "Kolmogorov-Smirnov (one-sample)",- |
-
456 | -! | -
- "Anderson-Darling (one-sample)",- |
-
457 | -! | -
- "Cramer-von Mises (one-sample)"- |
-
458 | -- |
- ))) {- |
-
459 | -! | -
- if (!shinyvalidate::input_provided(value)) {- |
-
460 | -! | -
- "Please select the theoretical distribution."- |
-
461 | -- |
- }- |
-
462 | -- |
- }- |
-
463 | -- |
- }- |
-
464 | -! | -
- iv_dist <- shinyvalidate::InputValidator$new()- |
-
465 | -! | -
- iv_dist$add_rule("t_dist", rule_dist)- |
-
466 | -! | -
- iv_dist$add_rule("dist_param1", rule_dist_1)- |
-
467 | -! | -
- iv_dist$add_rule("dist_param2", rule_dist_2)- |
-
468 | -! | -
- iv_dist$enable()- |
-
469 | -- | - - | -
470 | -! | -
- anl_merged_input <- teal.transform::merge_expression_srv(- |
-
471 | -! | -
- selector_list = selector_list,- |
-
472 | -! | -
- datasets = data- |
-
473 | -- |
- )- |
-
474 | -- | - - | -
475 | -! | -
- anl_merged_q <- reactive({- |
-
476 | -! | -
- req(anl_merged_input())- |
-
477 | -! | -
- data() %>%- |
-
478 | -! | -
- teal.code::eval_code(as.expression(anl_merged_input()$expr))- |
-
479 | -- |
- })- |
-
480 | -- | - - | -
481 | -! | -
- merged <- list(- |
-
482 | -! | -
- anl_input_r = anl_merged_input,- |
-
483 | -! | -
- anl_q_r = anl_merged_q- |
-
484 | -- |
- )- |
-
485 | -- | - - | -
486 | -! | -
- output$scales_types_ui <- renderUI({- |
-
487 | -! | -
- if ("group_i" %in% names(selector_list()) && length(selector_list()$group_i()$filters[[1]]$selected) > 0) {- |
-
488 | -! | -
- shinyWidgets::prettyRadioButtons(- |
-
489 | -! | -
- session$ns("scales_type"),- |
-
490 | -! | -
- label = "Scales:",- |
-
491 | -! | -
- choices = c("Fixed", "Free"),- |
-
492 | -! | -
- selected = "Fixed",- |
-
493 | -! | -
- bigger = FALSE,- |
-
494 | -! | -
- inline = TRUE- |
-
495 | -- |
- )- |
-
496 | -- |
- }- |
-
497 | -- |
- })- |
-
498 | -- | - - | -
499 | -! | -
- observeEvent(- |
-
500 | -! | -
- eventExpr = list(- |
-
501 | -! | -
- input$t_dist,- |
-
502 | -! | -
- input$params_reset,- |
-
503 | -! | -
- selector_list()$dist_i()$select- |
-
504 | -- |
- ),- |
-
505 | -! | -
- handlerExpr = {- |
-
506 | -! | -
- if (length(input$t_dist) != 0) {- |
-
507 | -! | -
- dist_var2 <- as.vector(merged$anl_input_r()$columns_source$dist_i)- |
-
508 | -- | - - | -
509 | -! | -
- get_dist_params <- function(x, dist) {- |
-
510 | -! | -
- if (dist == "unif") {- |
-
511 | -! | -
- res <- as.list(range(x))- |
-
512 | -! | -
- names(res) <- c("min", "max")- |
-
513 | -! | -
- return(res)- |
-
514 | -- |
- }- |
-
515 | -! | -
- tryCatch(- |
-
516 | -! | -
- as.list(MASS::fitdistr(x, densfun = dist)$estimate),- |
-
517 | -! | -
- error = function(e) list(param1 = NA, param2 = NA)- |
-
518 | -- |
- )- |
-
519 | -- |
- }- |
-
520 | -- | - - | -
521 | -! | -
- ANL <- merged$anl_q_r()[[as.character(dist_var[[1]]$dataname)]]- |
-
522 | -! | -
- params <- get_dist_params(as.numeric(stats::na.omit(ANL[[dist_var2]])), input$t_dist)- |
-
523 | -! | -
- params_vec <- round(unname(unlist(params)), 2)- |
-
524 | -! | -
- params_names <- names(params)- |
-
525 | -- | - - | -
526 | -! | -
- updateNumericInput(session, "dist_param1", label = params_names[1], value = params_vec[1])- |
-
527 | -! | -
- updateNumericInput(session, "dist_param2", label = params_names[2], value = params_vec[2])- |
-
528 | -- |
- } else {- |
-
529 | -! | -
- updateNumericInput(session, "dist_param1", label = "param1", value = NA)- |
-
530 | -! | -
- updateNumericInput(session, "dist_param2", label = "param2", value = NA)- |
-
531 | -- |
- }- |
-
532 | -- |
- },- |
-
533 | -! | -
- ignoreInit = TRUE- |
-
534 | -- |
- )- |
-
535 | -- | - - | -
536 | -! | -
- merge_vars <- reactive({- |
-
537 | -! | -
- teal::validate_inputs(iv_r())- |
-
538 | -- | - - | -
539 | -! | -
- dist_var <- as.vector(merged$anl_input_r()$columns_source$dist_i)- |
-
540 | -! | -
- s_var <- as.vector(merged$anl_input_r()$columns_source$strata_i)- |
-
541 | -! | -
- g_var <- as.vector(merged$anl_input_r()$columns_source$group_i)- |
-
542 | -- | - - | -
543 | -! | -
- dist_var_name <- if (length(dist_var)) as.name(dist_var) else NULL- |
-
544 | -! | -
- s_var_name <- if (length(s_var)) as.name(s_var) else NULL- |
-
545 | -! | -
- g_var_name <- if (length(g_var)) as.name(g_var) else NULL- |
-
546 | -- | - - | -
547 | -! | -
- list(- |
-
548 | -! | -
- dist_var = dist_var,- |
-
549 | -! | -
- s_var = s_var,- |
-
550 | -! | -
- g_var = g_var,- |
-
551 | -! | -
- dist_var_name = dist_var_name,- |
-
552 | -! | -
- s_var_name = s_var_name,- |
-
553 | -! | -
- g_var_name = g_var_name- |
-
554 | -- |
- )- |
-
555 | -- |
- })- |
-
556 | -- | - - | -
557 | -- |
- # common qenv- |
-
558 | -! | -
- common_q <- reactive({- |
-
559 | -- |
- # Create a private stack for this function only.- |
-
560 | -- | - - | -
561 | -! | -
- ANL <- merged$anl_q_r()[["ANL"]]- |
-
562 | -! | -
- dist_var <- merge_vars()$dist_var- |
-
563 | -! | -
- s_var <- merge_vars()$s_var- |
-
564 | -! | -
- g_var <- merge_vars()$g_var- |
-
565 | -- | - - | -
566 | -! | -
- dist_var_name <- merge_vars()$dist_var_name- |
-
567 | -! | -
- s_var_name <- merge_vars()$s_var_name- |
-
568 | -! | -
- g_var_name <- merge_vars()$g_var_name- |
-
569 | -- | - - | -
570 | -! | -
- roundn <- input$roundn- |
-
571 | -! | -
- dist_param1 <- input$dist_param1- |
-
572 | -! | -
- dist_param2 <- input$dist_param2- |
-
573 | -- |
- # isolated as dist_param1/dist_param2 already triggered the reactivity- |
-
574 | -! | -
- t_dist <- isolate(input$t_dist)- |
-
575 | -- | - - | -
576 | -! | -
- qenv <- merged$anl_q_r()- |
-
577 | -- | - - | -
578 | -! | -
- if (length(g_var) > 0) {- |
-
579 | -! | -
- validate(- |
-
580 | -! | -
- need(- |
-
581 | -! | -
- inherits(ANL[[g_var]], c("integer", "factor", "character")),- |
-
582 | -! | -
- "Group by variable must be `factor`, `character`, or `integer`"- |
-
583 | -- |
- )- |
-
584 | -- |
- )- |
-
585 | -! | -
- qenv <- teal.code::eval_code(- |
-
586 | -! | -
- qenv,- |
-
587 | -! | -
- substitute(- |
-
588 | -! | -
- expr = ANL[[g_var]] <- forcats::fct_na_value_to_level(as.factor(ANL[[g_var]]), "NA"),- |
-
589 | -! | -
- env = list(g_var = g_var)- |
-
590 | -- |
- )- |
-
591 | -- |
- )- |
-
592 | -- |
- }- |
-
593 | -- | - - | -
594 | -! | -
- if (length(s_var) > 0) {- |
-
595 | -! | -
- validate(- |
-
596 | -! | -
- need(- |
-
597 | -! | -
- inherits(ANL[[s_var]], c("integer", "factor", "character")),- |
-
598 | -! | -
- "Stratify by variable must be `factor`, `character`, or `integer`"- |
-
599 | -- |
- )- |
-
600 | -- |
- )- |
-
601 | -! | -
- qenv <- teal.code::eval_code(- |
-
602 | -! | -
- qenv,- |
-
603 | -! | -
- substitute(- |
-
604 | -! | -
- expr = ANL[[s_var]] <- forcats::fct_na_value_to_level(as.factor(ANL[[s_var]]), "NA"),- |
-
605 | -! | -
- env = list(s_var = s_var)- |
-
606 | -- |
- )- |
-
607 | -- |
- )- |
-
608 | -- |
- }- |
-
609 | -- | - - | -
610 | -! | -
- validate(need(is.numeric(ANL[[dist_var]]), "Please select a numeric variable."))- |
-
611 | -! | -
- teal::validate_has_data(ANL, 1, complete = TRUE)- |
-
612 | -- | - - | -
613 | -! | -
- if (length(t_dist) != 0) {- |
-
614 | -! | -
- map_distr_nams <- list(- |
-
615 | -! | -
- normal = c("mean", "sd"),- |
-
616 | -! | -
- lognormal = c("meanlog", "sdlog"),- |
-
617 | -! | -
- gamma = c("shape", "rate"),- |
-
618 | -! | -
- unif = c("min", "max")- |
-
619 | -- |
- )- |
-
620 | -! | -
- params_names_raw <- map_distr_nams[[t_dist]]- |
-
621 | -- | - - | -
622 | -! | -
- qenv <- teal.code::eval_code(- |
-
623 | -! | -
- qenv,- |
-
624 | -! | -
- substitute(- |
-
625 | -! | -
- expr = {- |
-
626 | -! | -
- params <- as.list(c(dist_param1, dist_param2))- |
-
627 | -! | -
- names(params) <- params_names_raw- |
-
628 | -- |
- },- |
-
629 | -! | -
- env = list(- |
-
630 | -! | -
- dist_param1 = dist_param1,- |
-
631 | -! | -
- dist_param2 = dist_param2,- |
-
632 | -! | -
- params_names_raw = params_names_raw- |
-
633 | -- |
- )- |
-
634 | -- |
- )- |
-
635 | -- |
- )- |
-
636 | -- |
- }- |
-
637 | -- | - - | -
638 | -! | -
- if (length(s_var) == 0 && length(g_var) == 0) {- |
-
639 | -! | -
- qenv <- teal.code::eval_code(- |
-
640 | -! | -
- qenv,- |
-
641 | -! | -
- substitute(- |
-
642 | -! | -
- expr = {- |
-
643 | -! | -
- summary_table <- ANL %>%- |
-
644 | -! | -
- dplyr::summarise(- |
-
645 | -! | -
- min = round(min(dist_var_name, na.rm = TRUE), roundn),- |
-
646 | -! | -
- median = round(stats::median(dist_var_name, na.rm = TRUE), roundn),- |
-
647 | -! | -
- mean = round(mean(dist_var_name, na.rm = TRUE), roundn),- |
-
648 | -! | -
- max = round(max(dist_var_name, na.rm = TRUE), roundn),- |
-
649 | -! | -
- sd = round(stats::sd(dist_var_name, na.rm = TRUE), roundn),- |
-
650 | -! | -
- count = dplyr::n()- |
-
651 | -- |
- )- |
-
652 | -- |
- },- |
-
653 | -! | -
- env = list(- |
-
654 | -! | -
- dist_var_name = as.name(dist_var),- |
-
655 | -! | -
- roundn = roundn- |
-
656 | -- |
- )- |
-
657 | -- |
- )- |
-
658 | -- |
- )- |
-
659 | -- |
- } else {- |
-
660 | -! | -
- qenv <- teal.code::eval_code(- |
-
661 | -! | -
- qenv,- |
-
662 | -! | -
- substitute(- |
-
663 | -! | -
- expr = {- |
-
664 | -! | -
- strata_vars <- strata_vars_raw- |
-
665 | -! | -
- summary_table <- ANL %>%- |
-
666 | -! | -
- dplyr::group_by_at(dplyr::vars(dplyr::any_of(strata_vars))) %>%- |
-
667 | -! | -
- dplyr::summarise(- |
-
668 | -! | -
- min = round(min(dist_var_name, na.rm = TRUE), roundn),- |
-
669 | -! | -
- median = round(stats::median(dist_var_name, na.rm = TRUE), roundn),- |
-
670 | -! | -
- mean = round(mean(dist_var_name, na.rm = TRUE), roundn),- |
-
671 | -! | -
- max = round(max(dist_var_name, na.rm = TRUE), roundn),- |
-
672 | -! | -
- sd = round(stats::sd(dist_var_name, na.rm = TRUE), roundn),- |
-
673 | -! | -
- count = dplyr::n()- |
-
674 | -- |
- )- |
-
675 | -! | -
- summary_table # used to display table when running show-r-code code- |
-
676 | -- |
- },- |
-
677 | -! | -
- env = list(- |
-
678 | -! | -
- dist_var_name = dist_var_name,- |
-
679 | -! | -
- strata_vars_raw = c(g_var, s_var),- |
-
680 | -! | -
- roundn = roundn- |
-
681 | -- |
- )- |
-
682 | -- |
- )- |
-
683 | -- |
- )- |
-
684 | -- |
- }- |
-
685 | -- |
- })- |
-
686 | -- | - - | -
687 | -- |
- # distplot qenv ----- |
-
688 | -! | -
- dist_q <- eventReactive(- |
-
689 | -! | -
- eventExpr = {- |
-
690 | -! | -
- common_q()- |
-
691 | -! | -
- input$scales_type- |
-
692 | -! | -
- input$main_type- |
-
693 | -! | -
- input$bins- |
-
694 | -! | -
- input$add_dens- |
-
695 | -! | -
- is.null(input$ggtheme)- |
-
696 | -- |
- },- |
-
697 | -! | -
- valueExpr = {- |
-
698 | -! | -
- dist_var <- merge_vars()$dist_var- |
-
699 | -! | -
- s_var <- merge_vars()$s_var- |
-
700 | -! | -
- g_var <- merge_vars()$g_var- |
-
701 | -! | -
- dist_var_name <- merge_vars()$dist_var_name- |
-
702 | -! | -
- s_var_name <- merge_vars()$s_var_name- |
-
703 | -! | -
- g_var_name <- merge_vars()$g_var_name- |
-
704 | -! | -
- t_dist <- input$t_dist- |
-
705 | -! | -
- dist_param1 <- input$dist_param1- |
-
706 | -! | -
- dist_param2 <- input$dist_param2- |
-
707 | -- | - - | -
708 | -! | -
- scales_type <- input$scales_type- |
-
709 | -- | - - | -
710 | -! | -
- ndensity <- 512- |
-
711 | -! | -
- main_type_var <- input$main_type- |
-
712 | -! | -
- bins_var <- input$bins- |
-
713 | -! | -
- add_dens_var <- input$add_dens- |
-
714 | -! | -
- ggtheme <- input$ggtheme- |
-
715 | -- | - - | -
716 | -! | -
- teal::validate_inputs(iv_dist)- |
-
717 | -- | - - | -
718 | -! | -
- qenv <- common_q()- |
-
719 | -- | - - | -
720 | -! | -
- m_type <- if (main_type_var == "Density") "density" else "count"- |
-
721 | -- | - - | -
722 | -! | -
- plot_call <- if (length(s_var) == 0 && length(g_var) == 0) {- |
-
723 | -! | -
- substitute(- |
-
724 | -! | -
- expr = ggplot(ANL, aes(dist_var_name)) +- |
-
725 | -! | -
- geom_histogram(- |
-
726 | -! | -
- position = "identity", aes(y = after_stat(m_type)), bins = bins_var, alpha = 0.3- |
-
727 | -- |
- ),- |
-
728 | -! | -
- env = list(- |
-
729 | -! | -
- m_type = as.name(m_type), bins_var = bins_var, dist_var_name = as.name(dist_var)- |
-
730 | -- |
- )- |
-
731 | -- |
- )- |
-
732 | -! | -
- } else if (length(s_var) != 0 && length(g_var) == 0) {- |
-
733 | -! | -
- substitute(- |
-
734 | -! | -
- expr = ggplot(ANL, aes(dist_var_name, col = s_var_name)) +- |
-
735 | -! | -
- geom_histogram(- |
-
736 | -! | -
- position = "identity", aes(y = after_stat(m_type), fill = s_var), bins = bins_var, alpha = 0.3- |
-
737 | -- |
- ),- |
-
738 | -! | -
- env = list(- |
-
739 | -! | -
- m_type = as.name(m_type),- |
-
740 | -! | -
- bins_var = bins_var,- |
-
741 | -! | -
- dist_var_name = dist_var_name,- |
-
742 | -! | -
- s_var = as.name(s_var),- |
-
743 | -! | -
- s_var_name = s_var_name- |
-
744 | -- |
- )- |
-
745 | -- |
- )- |
-
746 | -! | -
- } else if (length(s_var) == 0 && length(g_var) != 0) {- |
-
747 | -! | -
- req(scales_type)- |
-
748 | -! | -
- substitute(- |
-
749 | -! | -
- expr = ggplot(ANL[ANL[[g_var]] != "NA", ], aes(dist_var_name)) +- |
-
750 | -! | -
- geom_histogram(- |
-
751 | -! | -
- position = "identity", aes(y = after_stat(m_type)), bins = bins_var, alpha = 0.3- |
-
752 | -- |
- ) +- |
-
753 | -! | -
- facet_wrap(~g_var_name, ncol = 1, scales = scales_raw),- |
-
754 | -! | -
- env = list(- |
-
755 | -! | -
- m_type = as.name(m_type),- |
-
756 | -! | -
- bins_var = bins_var,- |
-
757 | -! | -
- dist_var_name = dist_var_name,- |
-
758 | -! | -
- g_var = g_var,- |
-
759 | -! | -
- g_var_name = g_var_name,- |
-
760 | -! | -
- scales_raw = tolower(scales_type)- |
-
761 | -- |
- )- |
-
762 | -- |
- )- |
-
763 | -- |
- } else {- |
-
764 | -! | -
- req(scales_type)- |
-
765 | -! | -
- substitute(- |
-
766 | -! | -
- expr = ggplot(ANL[ANL[[g_var]] != "NA", ], aes(dist_var_name, col = s_var_name)) +- |
-
767 | -! | -
- geom_histogram(- |
-
768 | -! | -
- position = "identity",- |
-
769 | -! | -
- aes(y = after_stat(m_type), fill = s_var), bins = bins_var, alpha = 0.3- |
-
770 | -- |
- ) +- |
-
771 | -! | -
- facet_wrap(~g_var_name, ncol = 1, scales = scales_raw),- |
-
772 | -! | -
- env = list(- |
-
773 | -! | -
- m_type = as.name(m_type),- |
-
774 | -! | -
- bins_var = bins_var,- |
-
775 | -! | -
- dist_var_name = dist_var_name,- |
-
776 | -! | -
- g_var = g_var,- |
-
777 | -! | -
- s_var = as.name(s_var),- |
-
778 | -! | -
- g_var_name = g_var_name,- |
-
779 | -! | -
- s_var_name = s_var_name,- |
-
780 | -! | -
- scales_raw = tolower(scales_type)- |
-
781 | -- |
- )- |
-
782 | -- |
- )- |
-
783 | -- |
- }- |
-
784 | -- | - - | -
785 | -! | -
- if (add_dens_var) {- |
-
786 | -! | -
- plot_call <- substitute(- |
-
787 | -! | -
- expr = plot_call +- |
-
788 | -! | -
- stat_density(- |
-
789 | -! | -
- aes(y = after_stat(const * m_type2)),- |
-
790 | -! | -
- geom = "line",- |
-
791 | -! | -
- position = "identity",- |
-
792 | -! | -
- alpha = 0.5,- |
-
793 | -! | -
- size = 2,- |
-
794 | -! | -
- n = ndensity- |
-
795 | -- |
- ),- |
-
796 | -! | -
- env = list(- |
-
797 | -! | -
- plot_call = plot_call,- |
-
798 | -! | -
- const = if (main_type_var == "Density") {- |
-
799 | -! | -
- 1- |
-
800 | -- |
- } else {- |
-
801 | -! | -
- diff(range(qenv[["ANL"]][[dist_var]], na.rm = TRUE)) / bins_var- |
-
802 | -- |
- },- |
-
803 | -! | -
- m_type2 = if (main_type_var == "Density") as.name("density") else as.name("count"),- |
-
804 | -! | -
- ndensity = ndensity- |
-
805 | -- |
- )- |
-
806 | -- |
- )- |
-
807 | -- |
- }- |
-
808 | -- | - - | -
809 | -! | -
- if (length(t_dist) != 0 && main_type_var == "Density" && length(g_var) == 0 && length(s_var) == 0) {- |
-
810 | -! | -
- qenv <- teal.code::eval_code(- |
-
811 | -! | -
- qenv,- |
-
812 | -! | -
- substitute(- |
-
813 | -! | -
- df_params <- as.data.frame(append(params, list(name = t_dist))),- |
-
814 | -! | -
- env = list(t_dist = t_dist)- |
-
815 | -- |
- )- |
-
816 | -- |
- )- |
-
817 | -! | -
- datas <- quote(data.frame(x = 0.7, y = 1, tb = I(list(df_params = df_params))))- |
-
818 | -! | -
- label <- quote(tb)- |
-
819 | -- | - - | -
820 | -! | -
- plot_call <- substitute(- |
-
821 | -! | -
- expr = plot_call + ggpp::geom_table_npc(- |
-
822 | -! | -
- data = data,- |
-
823 | -! | -
- aes(npcx = x, npcy = y, label = label),- |
-
824 | -! | -
- hjust = 0, vjust = 1, size = 4- |
-
825 | -- |
- ),- |
-
826 | -! | -
- env = list(plot_call = plot_call, data = datas, label = label)- |
-
827 | -- |
- )- |
-
828 | -- |
- }- |
-
829 | -- | - - | -
830 | -! | -
- if (- |
-
831 | -! | -
- length(s_var) == 0 &&- |
-
832 | -! | -
- length(g_var) == 0 &&- |
-
833 | -! | -
- main_type_var == "Density" &&- |
-
834 | -! | -
- length(t_dist) != 0 &&- |
-
835 | -! | -
- main_type_var == "Density"- |
-
836 | -- |
- ) {- |
-
837 | -! | -
- map_dist <- stats::setNames(- |
-
838 | -! | -
- c("dnorm", "dlnorm", "dgamma", "dunif"),- |
-
839 | -! | -
- c("normal", "lognormal", "gamma", "unif")- |
-
840 | -- |
- )- |
-
841 | -! | -
- plot_call <- substitute(- |
-
842 | -! | -
- expr = plot_call + stat_function(- |
-
843 | -! | -
- data = data.frame(x = range(ANL[[dist_var]]), color = mapped_dist),- |
-
844 | -! | -
- aes(x, color = color),- |
-
845 | -! | -
- fun = mapped_dist_name,- |
-
846 | -! | -
- n = ndensity,- |
-
847 | -! | -
- size = 2,- |
-
848 | -! | -
- args = params- |
-
849 | -- |
- ) +- |
-
850 | -! | -
- scale_color_manual(values = stats::setNames("blue", mapped_dist), aesthetics = "color"),- |
-
851 | -! | -
- env = list(- |
-
852 | -! | -
- plot_call = plot_call,- |
-
853 | -! | -
- dist_var = dist_var,- |
-
854 | -! | -
- ndensity = ndensity,- |
-
855 | -! | -
- mapped_dist = unname(map_dist[t_dist]),- |
-
856 | -! | -
- mapped_dist_name = as.name(unname(map_dist[t_dist]))- |
-
857 | -- |
- )- |
-
858 | -- |
- )- |
-
859 | -- |
- }- |
-
860 | -- | - - | -
861 | -! | -
- all_ggplot2_args <- teal.widgets::resolve_ggplot2_args(- |
-
862 | -! | -
- user_plot = ggplot2_args[["Histogram"]],- |
-
863 | -! | -
- user_default = ggplot2_args$default- |
-
864 | -- |
- )- |
-
865 | -- | - - | -
866 | -! | -
- parsed_ggplot2_args <- teal.widgets::parse_ggplot2_args(- |
-
867 | -! | -
- all_ggplot2_args,- |
-
868 | -! | -
- ggtheme = ggtheme- |
-
869 | -- |
- )- |
-
870 | -- | - - | -
871 | -! | -
- teal.code::eval_code(- |
-
872 | -! | -
- qenv,- |
-
873 | -! | -
- substitute(- |
-
874 | -! | -
- expr = {- |
-
875 | -! | -
- g <- plot_call- |
-
876 | -! | -
- print(g)- |
-
877 | -- |
- },- |
-
878 | -! | -
- env = list(plot_call = Reduce(function(x, y) call("+", x, y), c(plot_call, parsed_ggplot2_args)))- |
-
879 | -- |
- )- |
-
880 | -- |
- )- |
-
881 | -- |
- }- |
-
882 | -- |
- )- |
-
883 | -- | - - | -
884 | -- |
- # qqplot qenv ----- |
-
885 | -! | -
- qq_q <- eventReactive(- |
-
886 | -! | -
- eventExpr = {- |
-
887 | -! | -
- common_q()- |
-
888 | -! | -
- input$scales_type- |
-
889 | -! | -
- input$qq_line- |
-
890 | -! | -
- is.null(input$ggtheme)- |
-
891 | -- |
- },- |
-
892 | -! | -
- valueExpr = {- |
-
893 | -! | -
- dist_var <- merge_vars()$dist_var- |
-
894 | -! | -
- s_var <- merge_vars()$s_var- |
-
895 | -! | -
- g_var <- merge_vars()$g_var- |
-
896 | -! | -
- dist_var_name <- merge_vars()$dist_var_name- |
-
897 | -! | -
- s_var_name <- merge_vars()$s_var_name- |
-
898 | -! | -
- g_var_name <- merge_vars()$g_var_name- |
-
899 | -! | -
- t_dist <- input$t_dist- |
-
900 | -! | -
- dist_param1 <- input$dist_param1- |
-
901 | -! | -
- dist_param2 <- input$dist_param2- |
-
902 | -- | - - | -
903 | -! | -
- scales_type <- input$scales_type- |
-
904 | -! | -
- ggtheme <- input$ggtheme- |
-
905 | -- | - - | -
906 | -! | -
- teal::validate_inputs(iv_r_dist(), iv_dist)- |
-
907 | -- | - - | -
908 | -! | -
- qenv <- common_q()- |
-
909 | -- | - - | -
910 | -! | -
- plot_call <- if (length(s_var) == 0 && length(g_var) == 0) {- |
-
911 | -! | -
- substitute(- |
-
912 | -! | -
- expr = ggplot(ANL, aes_string(sample = dist_var)),- |
-
913 | -! | -
- env = list(dist_var = dist_var)- |
-
914 | -- |
- )- |
-
915 | -! | -
- } else if (length(s_var) != 0 && length(g_var) == 0) {- |
-
916 | -! | -
- substitute(- |
-
917 | -! | -
- expr = ggplot(ANL, aes_string(sample = dist_var, color = s_var)),- |
-
918 | -! | -
- env = list(dist_var = dist_var, s_var = s_var)- |
-
919 | -- |
- )- |
-
920 | -! | -
- } else if (length(s_var) == 0 && length(g_var) != 0) {- |
-
921 | -! | -
- substitute(- |
-
922 | -! | -
- expr = ggplot(ANL[ANL[[g_var]] != "NA", ], aes_string(sample = dist_var)) +- |
-
923 | -! | -
- facet_wrap(~g_var_name, ncol = 1, scales = scales_raw),- |
-
924 | -! | -
- env = list(- |
-
925 | -! | -
- dist_var = dist_var,- |
-
926 | -! | -
- g_var = g_var,- |
-
927 | -! | -
- g_var_name = g_var_name,- |
-
928 | -! | -
- scales_raw = tolower(scales_type)- |
-
929 | -- |
- )- |
-
930 | -- |
- )- |
-
931 | -- |
- } else {- |
-
932 | -! | -
- substitute(- |
-
933 | -! | -
- expr = ggplot(ANL[ANL[[g_var]] != "NA", ], aes_string(sample = dist_var, color = s_var)) +- |
-
934 | -! | -
- facet_wrap(~g_var_name, ncol = 1, scales = scales_raw),- |
-
935 | -! | -
- env = list(- |
-
936 | -! | -
- dist_var = dist_var,- |
-
937 | -! | -
- g_var = g_var,- |
-
938 | -! | -
- s_var = s_var,- |
-
939 | -! | -
- g_var_name = g_var_name,- |
-
940 | -! | -
- scales_raw = tolower(scales_type)- |
-
941 | -- |
- )- |
-
942 | -- |
- )- |
-
943 | -- |
- }- |
-
944 | -- | - - | -
945 | -! | -
- map_dist <- stats::setNames(- |
-
946 | -! | -
- c("qnorm", "qlnorm", "qgamma", "qunif"),- |
-
947 | -! | -
- c("normal", "lognormal", "gamma", "unif")- |
-
948 | -- |
- )- |
-
949 | -- | - - | -
950 | -! | -
- plot_call <- substitute(- |
-
951 | -! | -
- expr = plot_call +- |
-
952 | -! | -
- stat_qq(distribution = mapped_dist, dparams = params),- |
-
953 | -! | -
- env = list(plot_call = plot_call, mapped_dist = as.name(unname(map_dist[t_dist])))- |
-
954 | -- |
- )- |
-
955 | -- | - - | -
956 | -! | -
- if (length(t_dist) != 0 && length(g_var) == 0 && length(s_var) == 0) {- |
-
957 | -! | -
- qenv <- teal.code::eval_code(- |
-
958 | -! | -
- qenv,- |
-
959 | -! | -
- substitute(- |
-
960 | -! | -
- df_params <- as.data.frame(append(params, list(name = t_dist))),- |
-
961 | -! | -
- env = list(t_dist = t_dist)- |
-
962 | -- |
- )- |
-
963 | -- |
- )- |
-
964 | -! | -
- datas <- quote(data.frame(x = 0.7, y = 1, tb = I(list(df_params = df_params))))- |
-
965 | -! | -
- label <- quote(tb)- |
-
966 | -- | - - | -
967 | -! | -
- plot_call <- substitute(- |
-
968 | -! | -
- expr = plot_call +- |
-
969 | -! | -
- ggpp::geom_table_npc(- |
-
970 | -! | -
- data = data,- |
-
971 | -! | -
- aes(npcx = x, npcy = y, label = label),- |
-
972 | -! | -
- hjust = 0,- |
-
973 | -! | -
- vjust = 1,- |
-
974 | -! | -
- size = 4- |
-
975 | -- |
- ),- |
-
976 | -! | -
- env = list(- |
-
977 | -! | -
- plot_call = plot_call,- |
-
978 | -! | -
- data = datas,- |
-
979 | -! | -
- label = label- |
-
980 | -- |
- )- |
-
981 | -- |
- )- |
-
982 | -- |
- }- |
-
983 | -- | - - | -
984 | -! | -
- if (isTRUE(input$qq_line)) {- |
-
985 | -! | -
- plot_call <- substitute(- |
-
986 | -! | -
- expr = plot_call +- |
-
987 | -! | -
- stat_qq_line(distribution = mapped_dist, dparams = params),- |
-
988 | -! | -
- env = list(plot_call = plot_call, mapped_dist = as.name(unname(map_dist[t_dist])))- |
-
989 | -- |
- )- |
-
990 | -- |
- }- |
-
991 | -- | - - | -
992 | -! | -
- all_ggplot2_args <- teal.widgets::resolve_ggplot2_args(- |
-
993 | -! | -
- user_plot = ggplot2_args[["QQplot"]],- |
-
994 | -! | -
- user_default = ggplot2_args$default,- |
-
995 | -! | -
- module_plot = teal.widgets::ggplot2_args(labs = list(x = "theoretical", y = "sample"))- |
-
996 | -- |
- )- |
-
997 | -- | - - | -
998 | -! | -
- parsed_ggplot2_args <- teal.widgets::parse_ggplot2_args(- |
-
999 | -! | -
- all_ggplot2_args,- |
-
1000 | -! | -
- ggtheme = ggtheme- |
-
1001 | -- |
- )- |
-
1002 | -- | - - | -
1003 | -! | -
- teal.code::eval_code(- |
-
1004 | -! | -
- qenv,- |
-
1005 | -! | -
- substitute(- |
-
1006 | -! | -
- expr = {- |
-
1007 | -! | -
- g <- plot_call- |
-
1008 | -! | -
- print(g)- |
-
1009 | -- |
- },- |
-
1010 | -! | -
- env = list(plot_call = Reduce(function(x, y) call("+", x, y), c(plot_call, parsed_ggplot2_args)))- |
-
1011 | -- |
- )- |
-
1012 | -- |
- )- |
-
1013 | -- |
- }- |
-
1014 | -- |
- )- |
-
1015 | -- | - - | -
1016 | -- |
- # test qenv ----- |
-
1017 | -! | -
- test_q <- eventReactive(- |
-
1018 | -! | -
- ignoreNULL = FALSE,- |
-
1019 | -! | -
- eventExpr = {- |
-
1020 | -! | -
- common_q()- |
-
1021 | -! | -
- input$dist_param1- |
-
1022 | -! | -
- input$dist_param2- |
-
1023 | -! | -
- input$dist_tests- |
-
1024 | -- |
- },- |
-
1025 | -! | -
- valueExpr = {- |
-
1026 | -- |
- # Create a private stack for this function only.- |
-
1027 | -! | -
- ANL <- common_q()[["ANL"]]- |
-
1028 | -- | - - | -
1029 | -! | -
- dist_var <- merge_vars()$dist_var- |
-
1030 | -! | -
- s_var <- merge_vars()$s_var- |
-
1031 | -! | -
- g_var <- merge_vars()$g_var- |
-
1032 | -- | - - | -
1033 | -! | -
- dist_var_name <- merge_vars()$dist_var_name- |
-
1034 | -! | -
- s_var_name <- merge_vars()$s_var_name- |
-
1035 | -! | -
- g_var_name <- merge_vars()$g_var_name- |
-
1036 | -- | - - | -
1037 | -! | -
- dist_param1 <- input$dist_param1- |
-
1038 | -! | -
- dist_param2 <- input$dist_param2- |
-
1039 | -! | -
- dist_tests <- input$dist_tests- |
-
1040 | -! | -
- t_dist <- input$t_dist- |
-
1041 | -- | - - | -
1042 | -! | -
- validate(need(dist_tests, "Please select a test"))- |
-
1043 | -- | - - | -
1044 | -! | -
- teal::validate_inputs(iv_dist)- |
-
1045 | -- | - - | -
1046 | -! | -
- if (length(s_var) > 0 || length(g_var) > 0) {- |
-
1047 | -! | -
- counts <- ANL %>%- |
-
1048 | -! | -
- dplyr::group_by_at(dplyr::vars(dplyr::any_of(c(s_var, g_var)))) %>%- |
-
1049 | -! | -
- dplyr::summarise(n = dplyr::n())- |
-
1050 | -- | - - | -
1051 | -! | -
- validate(need(all(counts$n > 5), "Please select strata*group with at least 5 observation each."))- |
-
1052 | -- |
- }- |
-
1053 | -- | - - | -
1054 | -- | - - | -
1055 | -! | -
- if (dist_tests %in% c(- |
-
1056 | -! | -
- "t-test (two-samples, not paired)",- |
-
1057 | -! | -
- "F-test",- |
-
1058 | -! | -
- "Kolmogorov-Smirnov (two-samples)"- |
-
1059 | -- |
- )) {- |
-
1060 | -! | -
- if (length(g_var) == 0 && length(s_var) > 0) {- |
-
1061 | -! | -
- validate(need(- |
-
1062 | -! | -
- length(unique(ANL[[s_var]])) == 2,- |
-
1063 | -! | -
- "Please select stratify variable with 2 levels."- |
-
1064 | -- |
- ))- |
-
1065 | -- |
- }- |
-
1066 | -! | -
- if (length(g_var) > 0 && length(s_var) > 0) {- |
-
1067 | -! | -
- validate(need(- |
-
1068 | -! | -
- all(stats::na.omit(as.vector(- |
-
1069 | -! | -
- tapply(ANL[[s_var]], list(ANL[[g_var]]), function(x) length(unique(x))) == 2- |
-
1070 | -- |
- ))),- |
-
1071 | -! | -
- "Please select stratify variable with 2 levels, per each group."- |
-
1072 | -- |
- ))- |
-
1073 | -- |
- }- |
-
1074 | -- |
- }- |
-
1075 | -- | - - | -
1076 | -! | -
- map_dist <- stats::setNames(- |
-
1077 | -! | -
- c("pnorm", "plnorm", "pgamma", "punif"),- |
-
1078 | -! | -
- c("normal", "lognormal", "gamma", "unif")- |
-
1079 | -- |
- )- |
-
1080 | -! | -
- sks_args <- list(- |
-
1081 | -! | -
- test = quote(stats::ks.test),- |
-
1082 | -! | -
- args = bquote(append(list(.[[.(dist_var)]], .(map_dist[t_dist])), params)),- |
-
1083 | -! | -
- groups = c(g_var, s_var)- |
-
1084 | -- |
- )- |
-
1085 | -! | -
- ssw_args <- list(- |
-
1086 | -! | -
- test = quote(stats::shapiro.test),- |
-
1087 | -! | -
- args = bquote(list(.[[.(dist_var)]])),- |
-
1088 | -! | -
- groups = c(g_var, s_var)- |
-
1089 | -- |
- )- |
-
1090 | -! | -
- mfil_args <- list(- |
-
1091 | -! | -
- test = quote(stats::fligner.test),- |
-
1092 | -! | -
- args = bquote(list(.[[.(dist_var)]], .[[.(s_var)]])),- |
-
1093 | -! | -
- groups = c(g_var)- |
-
1094 | -- |
- )- |
-
1095 | -! | -
- sad_args <- list(- |
-
1096 | -! | -
- test = quote(goftest::ad.test),- |
-
1097 | -! | -
- args = bquote(append(list(.[[.(dist_var)]], .(map_dist[t_dist])), params)),- |
-
1098 | -! | -
- groups = c(g_var, s_var)- |
-
1099 | -- |
- )- |
-
1100 | -! | -
- scvm_args <- list(- |
-
1101 | -! | -
- test = quote(goftest::cvm.test),- |
-
1102 | -! | -
- args = bquote(append(list(.[[.(dist_var)]], .(map_dist[t_dist])), params)),- |
-
1103 | -! | -
- groups = c(g_var, s_var)- |
-
1104 | -- |
- )- |
-
1105 | -! | -
- manov_args <- list(- |
-
1106 | -! | -
- test = quote(stats::aov),- |
-
1107 | -! | -
- args = bquote(list(stats::formula(.(dist_var_name) ~ .(s_var_name)), .)),- |
-
1108 | -! | -
- groups = c(g_var)- |
-
1109 | -- |
- )- |
-
1110 | -! | -
- mt_args <- list(- |
-
1111 | -! | -
- test = quote(stats::t.test),- |
-
1112 | -! | -
- args = bquote(unname(split(.[[.(dist_var)]], .[[.(s_var)]], drop = TRUE))),- |
-
1113 | -! | -
- groups = c(g_var)- |
-
1114 | -- |
- )- |
-
1115 | -! | -
- mv_args <- list(- |
-
1116 | -! | -
- test = quote(stats::var.test),- |
-
1117 | -! | -
- args = bquote(unname(split(.[[.(dist_var)]], .[[.(s_var)]], drop = TRUE))),- |
-
1118 | -! | -
- groups = c(g_var)- |
-
1119 | -- |
- )- |
-
1120 | -! | -
- mks_args <- list(- |
-
1121 | -! | -
- test = quote(stats::ks.test),- |
-
1122 | -! | -
- args = bquote(unname(split(.[[.(dist_var)]], .[[.(s_var)]], drop = TRUE))),- |
-
1123 | -! | -
- groups = c(g_var)- |
-
1124 | -- |
- )- |
-
1125 | -- | - - | -
1126 | -! | -
- tests_base <- switch(dist_tests,- |
-
1127 | -! | -
- "Kolmogorov-Smirnov (one-sample)" = sks_args,- |
-
1128 | -! | -
- "Shapiro-Wilk" = ssw_args,- |
-
1129 | -! | -
- "Fligner-Killeen" = mfil_args,- |
-
1130 | -! | -
- "one-way ANOVA" = manov_args,- |
-
1131 | -! | -
- "t-test (two-samples, not paired)" = mt_args,- |
-
1132 | -! | -
- "F-test" = mv_args,- |
-
1133 | -! | -
- "Kolmogorov-Smirnov (two-samples)" = mks_args,- |
-
1134 | -! | -
- "Anderson-Darling (one-sample)" = sad_args,- |
-
1135 | -! | -
- "Cramer-von Mises (one-sample)" = scvm_args- |
-
1136 | -- |
- )- |
-
1137 | -- | - - | -
1138 | -! | -
- env <- list(- |
-
1139 | -! | -
- t_test = t_dist,- |
-
1140 | -! | -
- dist_var = dist_var,- |
-
1141 | -! | -
- g_var = g_var,- |
-
1142 | -! | -
- s_var = s_var,- |
-
1143 | -! | -
- args = tests_base$args,- |
-
1144 | -! | -
- groups = tests_base$groups,- |
-
1145 | -! | -
- test = tests_base$test,- |
-
1146 | -! | -
- dist_var_name = dist_var_name,- |
-
1147 | -! | -
- g_var_name = g_var_name,- |
-
1148 | -! | -
- s_var_name = s_var_name- |
-
1149 | -- |
- )- |
-
1150 | -- | - - | -
1151 | -! | -
- qenv <- common_q()- |
-
1152 | -- | - - | -
1153 | -! | -
- if (length(s_var) == 0 && length(g_var) == 0) {- |
-
1154 | -! | -
- qenv <- teal.code::eval_code(- |
-
1155 | -! | -
- qenv,- |
-
1156 | -! | -
- substitute(- |
-
1157 | -! | -
- expr = {- |
-
1158 | -! | -
- test_stats <- ANL %>%- |
-
1159 | -! | -
- dplyr::select(dist_var) %>%- |
-
1160 | -! | -
- with(., broom::glance(do.call(test, args))) %>%- |
-
1161 | -! | -
- dplyr::mutate_if(is.numeric, round, 3)- |
-
1162 | -- |
- },- |
-
1163 | -! | -
- env = env- |
-
1164 | -- |
- )- |
-
1165 | -- |
- )- |
-
1166 | -- |
- } else {- |
-
1167 | -! | -
- qenv <- teal.code::eval_code(- |
-
1168 | -! | -
- qenv,- |
-
1169 | -! | -
- substitute(- |
-
1170 | -! | -
- expr = {- |
-
1171 | -! | -
- test_stats <- ANL %>%- |
-
1172 | -! | -
- dplyr::select(dist_var, s_var, g_var) %>%- |
-
1173 | -! | -
- dplyr::group_by_at(dplyr::vars(dplyr::any_of(groups))) %>%- |
-
1174 | -! | -
- dplyr::do(tests = broom::glance(do.call(test, args))) %>%- |
-
1175 | -! | -
- tidyr::unnest(tests) %>%- |
-
1176 | -! | -
- dplyr::mutate_if(is.numeric, round, 3)- |
-
1177 | -- |
- },- |
-
1178 | -! | -
- env = env- |
-
1179 | -- |
- )- |
-
1180 | -- |
- )- |
-
1181 | -- |
- }- |
-
1182 | -! | -
- qenv %>%- |
-
1183 | -- |
- # used to display table when running show-r-code code- |
-
1184 | -! | -
- teal.code::eval_code(quote(test_stats))- |
-
1185 | -- |
- }- |
-
1186 | -- |
- )- |
-
1187 | -- | - - | -
1188 | -- |
- # outputs ----- |
-
1189 | -- |
- ## building main qenv- |
-
1190 | -! | -
- output_q <- reactive({- |
-
1191 | -! | -
- tab <- input$tabs- |
-
1192 | -! | -
- req(tab) # tab is NULL upon app launch, hence will crash without this statement- |
-
1193 | -- | - - | -
1194 | -! | -
- qenv_final <- common_q()- |
-
1195 | -- |
- # wrapped in if since could lead into validate error - we do want to continue- |
-
1196 | -! | -
- test_r_qenv_out <- try(test_q(), silent = TRUE)- |
-
1197 | -! | -
- if (!inherits(test_r_qenv_out, c("try-error", "error"))) {- |
-
1198 | -! | -
- qenv_final <- teal.code::join(qenv_final, test_q())- |
-
1199 | -- |
- }- |
-
1200 | -- | - - | -
1201 | -! | -
- qenv_final <- if (tab == "Histogram") {- |
-
1202 | -! | -
- req(dist_q())- |
-
1203 | -! | -
- teal.code::join(qenv_final, dist_q())- |
-
1204 | -! | -
- } else if (tab == "QQplot") {- |
-
1205 | -! | -
- req(qq_q())- |
-
1206 | -! | -
- teal.code::join(qenv_final, qq_q())- |
-
1207 | -- |
- }- |
-
1208 | -! | -
- qenv_final- |
-
1209 | -- |
- })- |
-
1210 | -- | - - | -
1211 | -! | -
- dist_r <- reactive(dist_q()[["g"]])- |
-
1212 | -- | - - | -
1213 | -! | -
- qq_r <- reactive(qq_q()[["g"]])- |
-
1214 | -- | - - | -
1215 | -! | -
- output$summary_table <- DT::renderDataTable(- |
-
1216 | -! | -
- expr = if (iv_r()$is_valid()) common_q()[["summary_table"]] else NULL,- |
-
1217 | -! | -
- options = list(- |
-
1218 | -! | -
- autoWidth = TRUE,- |
-
1219 | -! | -
- columnDefs = list(list(width = "200px", targets = "_all"))- |
-
1220 | -- |
- ),- |
-
1221 | -! | -
- rownames = FALSE- |
-
1222 | -- |
- )- |
-
1223 | -- | - - | -
1224 | -! | -
- tests_r <- reactive({- |
-
1225 | -! | -
- req(iv_r()$is_valid())- |
-
1226 | -! | -
- teal::validate_inputs(iv_r_dist())- |
-
1227 | -! | -
- test_q()[["test_stats"]]- |
-
1228 | -- |
- })- |
-
1229 | -- | - - | -
1230 | -! | -
- pws1 <- teal.widgets::plot_with_settings_srv(- |
-
1231 | -! | -
- id = "hist_plot",- |
-
1232 | -! | -
- plot_r = dist_r,- |
-
1233 | -! | -
- height = plot_height,- |
-
1234 | -! | -
- width = plot_width,- |
-
1235 | -! | -
- brushing = FALSE- |
-
1236 | -- |
- )- |
-
1237 | -- | - - | -
1238 | -! | -
- pws2 <- teal.widgets::plot_with_settings_srv(- |
-
1239 | -! | -
- id = "qq_plot",- |
-
1240 | -! | -
- plot_r = qq_r,- |
-
1241 | -! | -
- height = plot_height,- |
-
1242 | -! | -
- width = plot_width,- |
-
1243 | -! | -
- brushing = FALSE- |
-
1244 | -- |
- )- |
-
1245 | -- | - - | -
1246 | -! | -
- output$t_stats <- DT::renderDataTable(- |
-
1247 | -! | -
- expr = tests_r(),- |
-
1248 | -! | -
- options = list(scrollX = TRUE),- |
-
1249 | -! | -
- rownames = FALSE- |
-
1250 | -- |
- )- |
-
1251 | -- | - - | -
1252 | -! | -
- teal.widgets::verbatim_popup_srv(- |
-
1253 | -! | -
- id = "warning",- |
-
1254 | -! | -
- verbatim_content = reactive(teal.code::get_warnings(output_q())),- |
-
1255 | -! | -
- title = "Warning",- |
-
1256 | -! | -
- disabled = reactive(is.null(teal.code::get_warnings(output_q())))- |
-
1257 | -- |
- )- |
-
1258 | -- | - - | -
1259 | -! | -
- teal.widgets::verbatim_popup_srv(- |
-
1260 | -! | -
- id = "rcode",- |
-
1261 | -! | -
- verbatim_content = reactive(teal.code::get_code(output_q())),- |
-
1262 | -! | -
- title = "R Code for distribution"- |
-
1263 | -- |
- )- |
-
1264 | -- | - - | -
1265 | -- |
- ### REPORTER- |
-
1266 | -! | -
- if (with_reporter) {- |
-
1267 | -! | -
- card_fun <- function(comment, label) {- |
-
1268 | -! | -
- card <- teal::report_card_template(- |
-
1269 | -! | -
- title = "Distribution Plot",- |
-
1270 | -! | -
- label = label,- |
-
1271 | -! | -
- with_filter = with_filter,- |
-
1272 | -! | -
- filter_panel_api = filter_panel_api- |
-
1273 | -- |
- )- |
-
1274 | -! | -
- card$append_text("Plot", "header3")- |
-
1275 | -! | -
- if (input$tabs == "Histogram") {- |
-
1276 | -! | -
- card$append_plot(dist_r(), dim = pws1$dim())- |
-
1277 | -! | -
- } else if (input$tabs == "QQplot") {- |
-
1278 | -! | -
- card$append_plot(qq_r(), dim = pws2$dim())- |
-
1279 | -- |
- }- |
-
1280 | -! | -
- card$append_text("Statistics table", "header3")- |
-
1281 | -- | - - | -
1282 | -! | -
- card$append_table(common_q()[["summary_table"]])- |
-
1283 | -! | -
- tests_error <- tryCatch(expr = tests_r(), error = function(e) "error")- |
-
1284 | -! | -
- if (inherits(tests_error, "data.frame")) {- |
-
1285 | -! | -
- card$append_text("Tests table", "header3")- |
-
1286 | -! | -
- card$append_table(tests_r())- |
-
1287 | -- |
- }- |
-
1288 | -- | - - | -
1289 | -! | -
- if (!comment == "") {- |
-
1290 | -! | -
- card$append_text("Comment", "header3")- |
-
1291 | -! | -
- card$append_text(comment)- |
-
1292 | -- |
- }- |
-
1293 | -! | -
- card$append_src(teal.code::get_code(output_q()))- |
-
1294 | -! | -
- card- |
-
1295 | -- |
- }- |
-
1296 | -! | -
- teal.reporter::simple_reporter_srv("simple_reporter", reporter = reporter, card_fun = card_fun)- |
-
1297 | -- |
- }- |
-
1298 | -- |
- ###- |
-
1299 | -- |
- })- |
-
1300 | -- |
- }- |
-
1 | -- |
- #' `teal` module: Univariate and bivariate visualizations- |
-
2 | -- |
- #'- |
-
3 | -- |
- #' Module enables the creation of univariate and bivariate plots,- |
-
4 | -- |
- #' facilitating the exploration of data distributions and relationships between two variables.- |
-
5 | -- |
- #'- |
-
6 | -- |
- #' This is a general module to visualize 1 & 2 dimensional data.- |
-
7 | -- |
- #'- |
-
8 | -- |
- #' @note- |
-
9 | -- |
- #' For more examples, please see the vignette "Using bivariate plot" via- |
-
10 | -- |
- #' `vignette("using-bivariate-plot", package = "teal.modules.general")`.- |
-
11 | -- |
- #'- |
-
12 | -- |
- #' @inheritParams teal::module- |
-
13 | -- |
- #' @inheritParams shared_params- |
-
14 | -- |
- #' @param x (`data_extract_spec` or `list` of multiple `data_extract_spec`)- |
-
15 | -- |
- #' Variable names selected to plot along the x-axis by default.- |
-
16 | -- |
- #' Can be numeric, factor or character.- |
-
17 | -- |
- #' No empty selections are allowed.- |
-
18 | -- |
- #' @param y (`data_extract_spec` or `list` of multiple `data_extract_spec`)- |
-
19 | -- |
- #' Variable names selected to plot along the y-axis by default.- |
-
20 | -- |
- #' Can be numeric, factor or character.- |
-
21 | -- |
- #' @param use_density (`logical`) optional, indicates whether to plot density (`TRUE`) or frequency (`FALSE`).- |
-
22 | -- |
- #' Defaults to frequency (`FALSE`).- |
-
23 | -- |
- #' @param row_facet (`data_extract_spec` or `list` of multiple `data_extract_spec`) optional,- |
-
24 | -- |
- #' specification of the data variable(s) to use for faceting rows.- |
-
25 | -- |
- #' @param col_facet (`data_extract_spec` or `list` of multiple `data_extract_spec`) optional,- |
-
26 | -- |
- #' specification of the data variable(s) to use for faceting columns.- |
-
27 | -- |
- #' @param facet (`logical`) optional, specifies whether the facet encodings `ui` elements are toggled- |
-
28 | -- |
- #' on and shown to the user by default. Defaults to `TRUE` if either `row_facet` or `column_facet`- |
-
29 | -- |
- #' are supplied.- |
-
30 | -- |
- #' @param color_settings (`logical`) Whether coloring, filling and size should be applied- |
-
31 | -- |
- #' and `UI` tool offered to the user.- |
-
32 | -- |
- #' @param color (`data_extract_spec` or `list` of multiple `data_extract_spec`) optional,- |
-
33 | -- |
- #' specification of the data variable(s) selected for the outline color inside the coloring settings.- |
-
34 | -- |
- #' It will be applied when `color_settings` is set to `TRUE`.- |
-
35 | -- |
- #' @param fill (`data_extract_spec` or `list` of multiple `data_extract_spec`) optional,- |
-
36 | -- |
- #' specification of the data variable(s) selected for the fill color inside the coloring settings.- |
-
37 | -- |
- #' It will be applied when `color_settings` is set to `TRUE`.- |
-
38 | -- |
- #' @param size (`data_extract_spec` or `list` of multiple `data_extract_spec`) optional,- |
-
39 | -- |
- #' specification of the data variable(s) selected for the size of `geom_point` plots inside the coloring settings.- |
-
40 | -- |
- #' It will be applied when `color_settings` is set to `TRUE`.- |
-
41 | -- |
- #' @param free_x_scales (`logical`) optional, whether X scaling shall be changeable.- |
-
42 | -- |
- #' Does not allow scaling to be changed by default (`FALSE`).- |
-
43 | -- |
- #' @param free_y_scales (`logical`) optional, whether Y scaling shall be changeable.- |
-
44 | -- |
- #' Does not allow scaling to be changed by default (`FALSE`).- |
-
45 | -- |
- #' @param swap_axes (`logical`) optional, whether to swap X and Y axes. Defaults to `FALSE`.- |
-
46 | -- |
- #'- |
-
47 | -- |
- #' @inherit shared_params return- |
-
48 | -- |
- #'- |
-
49 | -- |
- #' @examples- |
-
50 | -- |
- #' library(teal.widgets)- |
-
51 | -- |
- #'- |
-
52 | -- |
- #' # general data example- |
-
53 | -- |
- #' data <- teal_data()- |
-
54 | -- |
- #' data <- within(data, {- |
-
55 | -- |
- #' require(nestcolor)- |
-
56 | -- |
- #' CO2 <- data.frame(CO2)- |
-
57 | -- |
- #' })- |
-
58 | -- |
- #' datanames(data) <- c("CO2")- |
-
59 | -- |
- #' join_keys(data) <- default_cdisc_join_keys[datanames(data)]- |
-
60 | -- |
- #'- |
-
61 | -- |
- #' app <- init(- |
-
62 | -- |
- #' data = data,- |
-
63 | -- |
- #' modules = modules(- |
-
64 | -- |
- #' tm_g_bivariate(- |
-
65 | -- |
- #' x = data_extract_spec(- |
-
66 | -- |
- #' dataname = "CO2",- |
-
67 | -- |
- #' select = select_spec(- |
-
68 | -- |
- #' label = "Select variable:",- |
-
69 | -- |
- #' choices = variable_choices(data[["CO2"]]),- |
-
70 | -- |
- #' selected = "conc",- |
-
71 | -- |
- #' fixed = FALSE- |
-
72 | -- |
- #' )- |
-
73 | -- |
- #' ),- |
-
74 | -- |
- #' y = data_extract_spec(- |
-
75 | -- |
- #' dataname = "CO2",- |
-
76 | -- |
- #' select = select_spec(- |
-
77 | -- |
- #' label = "Select variable:",- |
-
78 | -- |
- #' choices = variable_choices(data[["CO2"]]),- |
-
79 | -- |
- #' selected = "uptake",- |
-
80 | -- |
- #' multiple = FALSE,- |
-
81 | -- |
- #' fixed = FALSE- |
-
82 | -- |
- #' )- |
-
83 | -- |
- #' ),- |
-
84 | -- |
- #' row_facet = data_extract_spec(- |
-
85 | -- |
- #' dataname = "CO2",- |
-
86 | -- |
- #' select = select_spec(- |
-
87 | -- |
- #' label = "Select variable:",- |
-
88 | -- |
- #' choices = variable_choices(data[["CO2"]]),- |
-
89 | -- |
- #' selected = "Type",- |
-
90 | -- |
- #' fixed = FALSE- |
-
91 | -- |
- #' )- |
-
92 | -- |
- #' ),- |
-
93 | -- |
- #' col_facet = data_extract_spec(- |
-
94 | -- |
- #' dataname = "CO2",- |
-
95 | -- |
- #' select = select_spec(- |
-
96 | -- |
- #' label = "Select variable:",- |
-
97 | -- |
- #' choices = variable_choices(data[["CO2"]]),- |
-
98 | -- |
- #' selected = "Treatment",- |
-
99 | -- |
- #' fixed = FALSE- |
-
100 | -- |
- #' )- |
-
101 | -- |
- #' ),- |
-
102 | -- |
- #' ggplot2_args = ggplot2_args(- |
-
103 | -- |
- #' labs = list(subtitle = "Plot generated by Bivariate Module")- |
-
104 | -- |
- #' )- |
-
105 | -- |
- #' )- |
-
106 | -- |
- #' )- |
-
107 | -- |
- #' )- |
-
108 | -- |
- #' if (interactive()) {- |
-
109 | -- |
- #' shinyApp(app$ui, app$server)- |
-
110 | -- |
- #' }- |
-
111 | -- |
- #'- |
-
112 | -- |
- #'- |
-
113 | -- |
- #' # CDISC data example- |
-
114 | -- |
- #' data <- teal_data()- |
-
115 | -- |
- #' data <- within(data, {- |
-
116 | -- |
- #' require(nestcolor)- |
-
117 | -- |
- #' ADSL <- rADSL- |
-
118 | -- |
- #' })- |
-
119 | -- |
- #' datanames(data) <- c("ADSL")- |
-
120 | -- |
- #' join_keys(data) <- default_cdisc_join_keys[datanames(data)]- |
-
121 | -- |
- #'- |
-
122 | -- |
- #' app <- init(- |
-
123 | -- |
- #' data = data,- |
-
124 | -- |
- #' modules = modules(- |
-
125 | -- |
- #' tm_g_bivariate(- |
-
126 | -- |
- #' x = data_extract_spec(- |
-
127 | -- |
- #' dataname = "ADSL",- |
-
128 | -- |
- #' select = select_spec(- |
-
129 | -- |
- #' label = "Select variable:",- |
-
130 | -- |
- #' choices = variable_choices(data[["ADSL"]]),- |
-
131 | -- |
- #' selected = "AGE",- |
-
132 | -- |
- #' fixed = FALSE- |
-
133 | -- |
- #' )- |
-
134 | -- |
- #' ),- |
-
135 | -- |
- #' y = data_extract_spec(- |
-
136 | -- |
- #' dataname = "ADSL",- |
-
137 | -- |
- #' select = select_spec(- |
-
138 | -- |
- #' label = "Select variable:",- |
-
139 | -- |
- #' choices = variable_choices(data[["ADSL"]]),- |
-
140 | -- |
- #' selected = "SEX",- |
-
141 | -- |
- #' multiple = FALSE,- |
-
142 | -- |
- #' fixed = FALSE- |
-
143 | -- |
- #' )- |
-
144 | -- |
- #' ),- |
-
145 | -- |
- #' row_facet = data_extract_spec(- |
-
146 | -- |
- #' dataname = "ADSL",- |
-
147 | -- |
- #' select = select_spec(- |
-
148 | -- |
- #' label = "Select variable:",- |
-
149 | -- |
- #' choices = variable_choices(data[["ADSL"]]),- |
-
150 | -- |
- #' selected = "ARM",- |
-
151 | -- |
- #' fixed = FALSE- |
-
152 | -- |
- #' )- |
-
153 | -- |
- #' ),- |
-
154 | -- |
- #' col_facet = data_extract_spec(- |
-
155 | -- |
- #' dataname = "ADSL",- |
-
156 | -- |
- #' select = select_spec(- |
-
157 | -- |
- #' label = "Select variable:",- |
-
158 | -- |
- #' choices = variable_choices(data[["ADSL"]]),- |
-
159 | -- |
- #' selected = "COUNTRY",- |
-
160 | -- |
- #' fixed = FALSE- |
-
161 | -- |
- #' )- |
-
162 | -- |
- #' ),- |
-
163 | -- |
- #' ggplot2_args = ggplot2_args(- |
-
164 | -- |
- #' labs = list(subtitle = "Plot generated by Bivariate Module")- |
-
165 | -- |
- #' )- |
-
166 | -- |
- #' )- |
-
167 | -- |
- #' )- |
-
168 | -- |
- #' )- |
-
169 | -- |
- #' if (interactive()) {- |
-
170 | -- |
- #' shinyApp(app$ui, app$server)- |
-
171 | -- |
- #' }- |
-
172 | -- |
- #'- |
-
173 | -- |
- #' @export- |
-
174 | -- |
- #'- |
-
175 | -- |
- tm_g_bivariate <- function(label = "Bivariate Plots",- |
-
176 | -- |
- x,- |
-
177 | -- |
- y,- |
-
178 | -- |
- row_facet = NULL,- |
-
179 | -- |
- col_facet = NULL,- |
-
180 | -- |
- facet = !is.null(row_facet) || !is.null(col_facet),- |
-
181 | -- |
- color = NULL,- |
-
182 | -- |
- fill = NULL,- |
-
183 | -- |
- size = NULL,- |
-
184 | -- |
- use_density = FALSE,- |
-
185 | -- |
- color_settings = FALSE,- |
-
186 | -- |
- free_x_scales = FALSE,- |
-
187 | -- |
- free_y_scales = FALSE,- |
-
188 | -- |
- plot_height = c(600, 200, 2000),- |
-
189 | -- |
- plot_width = NULL,- |
-
190 | -- |
- rotate_xaxis_labels = FALSE,- |
-
191 | -- |
- swap_axes = FALSE,- |
-
192 | -- |
- ggtheme = c("gray", "bw", "linedraw", "light", "dark", "minimal", "classic", "void"),- |
-
193 | -- |
- ggplot2_args = teal.widgets::ggplot2_args(),- |
-
194 | -- |
- pre_output = NULL,- |
-
195 | -- |
- post_output = NULL) {- |
-
196 | -18x | -
- logger::log_info("Initializing tm_g_bivariate")- |
-
197 | -- | - - | -
198 | -- |
- # Normalize the parameters- |
-
199 | -14x | -
- if (inherits(x, "data_extract_spec")) x <- list(x)- |
-
200 | -13x | -
- if (inherits(y, "data_extract_spec")) y <- list(y)- |
-
201 | -1x | -
- if (inherits(row_facet, "data_extract_spec")) row_facet <- list(row_facet)- |
-
202 | -1x | -
- if (inherits(col_facet, "data_extract_spec")) col_facet <- list(col_facet)- |
-
203 | -1x | -
- if (inherits(color, "data_extract_spec")) color <- list(color)- |
-
204 | -1x | -
- if (inherits(fill, "data_extract_spec")) fill <- list(fill)- |
-
205 | -1x | -
- if (inherits(size, "data_extract_spec")) size <- list(size)- |
-
206 | -- | - - | -
207 | -- |
- # Start of assertions- |
-
208 | -18x | -
- checkmate::assert_string(label)- |
-
209 | -- | - - | -
210 | -18x | -
- checkmate::assert_list(x, types = "data_extract_spec")- |
-
211 | -18x | -
- assert_single_selection(x)- |
-
212 | -- | - - | -
213 | -16x | -
- checkmate::assert_list(y, types = "data_extract_spec")- |
-
214 | -16x | -
- assert_single_selection(y)- |
-
215 | -- | - - | -
216 | -14x | -
- checkmate::assert_list(row_facet, types = "data_extract_spec", null.ok = TRUE)- |
-
217 | -14x | -
- assert_single_selection(row_facet)- |
-
218 | -- | - - | -
219 | -14x | -
- checkmate::assert_list(col_facet, types = "data_extract_spec", null.ok = TRUE)- |
-
220 | -14x | -
- assert_single_selection(col_facet)- |
-
221 | -- | - - | -
222 | -14x | -
- checkmate::assert_flag(facet)- |
-
223 | -- | - - | -
224 | -14x | -
- checkmate::assert_list(color, types = "data_extract_spec", null.ok = TRUE)- |
-
225 | -14x | -
- assert_single_selection(color)- |
-
226 | -- | - - | -
227 | -14x | -
- checkmate::assert_list(fill, types = "data_extract_spec", null.ok = TRUE)- |
-
228 | -14x | -
- assert_single_selection(fill)- |
-
229 | -- | - - | -
230 | -14x | -
- checkmate::assert_list(size, types = "data_extract_spec", null.ok = TRUE)- |
-
231 | -14x | -
- assert_single_selection(size)- |
-
232 | -- | - - | -
233 | -14x | -
- checkmate::assert_flag(use_density)- |
-
234 | -- | - - | -
235 | -- |
- # Determines color, fill & size if they are not explicitly set- |
-
236 | -14x | -
- checkmate::assert_flag(color_settings)- |
-
237 | -14x | -
- if (color_settings) {- |
-
238 | -2x | -
- if (is.null(color)) {- |
-
239 | -2x | -
- color <- x- |
-
240 | -2x | -
- color[[1]]$select <- teal.transform::select_spec(choices = color[[1]]$select$choices, selected = NULL)- |
-
241 | -- |
- }- |
-
242 | -2x | -
- if (is.null(fill)) {- |
-
243 | -2x | -
- fill <- x- |
-
244 | -2x | -
- fill[[1]]$select <- teal.transform::select_spec(choices = fill[[1]]$select$choices, selected = NULL)- |
-
245 | -- |
- }- |
-
246 | -2x | -
- if (is.null(size)) {- |
-
247 | -2x | -
- size <- x- |
-
248 | -2x | -
- size[[1]]$select <- teal.transform::select_spec(choices = size[[1]]$select$choices, selected = NULL)- |
-
249 | -- |
- }- |
-
250 | -- |
- } else {- |
-
251 | -12x | -
- if (!is.null(c(color, fill, size))) {- |
-
252 | -3x | -
- stop("'color_settings' argument needs to be set to TRUE if 'color', 'fill', and/or 'size' is/are supplied.")- |
-
253 | -- |
- }- |
-
254 | -- |
- }- |
-
255 | -- | - - | -
256 | -11x | -
- checkmate::assert_flag(free_x_scales)- |
-
257 | -11x | -
- checkmate::assert_flag(free_y_scales)- |
-
258 | -- | - - | -
259 | -11x | -
- checkmate::assert_numeric(plot_height, len = 3, any.missing = FALSE, finite = TRUE)- |
-
260 | -10x | -
- checkmate::assert_numeric(plot_height[1], lower = plot_height[2], upper = plot_height[3], .var.name = "plot_height")- |
-
261 | -8x | -
- checkmate::assert_numeric(plot_width, len = 3, any.missing = FALSE, null.ok = TRUE, finite = TRUE)- |
-
262 | -7x | -
- checkmate::assert_numeric(- |
-
263 | -7x | -
- plot_width[1],- |
-
264 | -7x | -
- lower = plot_width[2], upper = plot_width[3], null.ok = TRUE, .var.name = "plot_width"- |
-
265 | -- |
- )- |
-
266 | -- | - - | -
267 | -5x | -
- checkmate::assert_flag(rotate_xaxis_labels)- |
-
268 | -5x | -
- checkmate::assert_flag(swap_axes)- |
-
269 | -- | - - | -
270 | -5x | -
- ggtheme <- match.arg(ggtheme)- |
-
271 | -5x | -
- checkmate::assert_class(ggplot2_args, "ggplot2_args")- |
-
272 | -- | - - | -
273 | -5x | -
- checkmate::assert_multi_class(pre_output, c("shiny.tag", "shiny.tag.list", "html"), null.ok = TRUE)- |
-
274 | -5x | -
- checkmate::assert_multi_class(post_output, c("shiny.tag", "shiny.tag.list", "html"), null.ok = TRUE)- |
-
275 | -- |
- # End of assertions- |
-
276 | -- | - - | -
277 | -- |
- # Make UI args- |
-
278 | -5x | -
- args <- as.list(environment())- |
-
279 | -- | - - | -
280 | -5x | -
- data_extract_list <- list(- |
-
281 | -5x | -
- x = x,- |
-
282 | -5x | -
- y = y,- |
-
283 | -5x | -
- row_facet = row_facet,- |
-
284 | -5x | -
- col_facet = col_facet,- |
-
285 | -5x | -
- color_settings = color_settings,- |
-
286 | -5x | -
- color = color,- |
-
287 | -5x | -
- fill = fill,- |
-
288 | -5x | -
- size = size- |
-
289 | -- |
- )- |
-
290 | -- | - - | -
291 | -5x | -
- module(- |
-
292 | -5x | -
- label = label,- |
-
293 | -5x | -
- server = srv_g_bivariate,- |
-
294 | -5x | -
- ui = ui_g_bivariate,- |
-
295 | -5x | -
- ui_args = args,- |
-
296 | -5x | -
- server_args = c(- |
-
297 | -5x | -
- data_extract_list,- |
-
298 | -5x | -
- list(plot_height = plot_height, plot_width = plot_width, ggplot2_args = ggplot2_args)- |
-
299 | -- |
- ),- |
-
300 | -5x | -
- datanames = teal.transform::get_extract_datanames(data_extract_list)- |
-
301 | -- |
- )- |
-
302 | -- |
- }- |
-
303 | -- | - - | -
304 | -- |
- # UI function for the bivariate module- |
-
305 | -- |
- ui_g_bivariate <- function(id, ...) {- |
-
306 | -! | -
- args <- list(...)- |
-
307 | -! | -
- is_single_dataset_value <- teal.transform::is_single_dataset(- |
-
308 | -! | -
- args$x, args$y, args$row_facet, args$col_facet, args$color, args$fill, args$size- |
-
309 | -- |
- )- |
-
310 | -- | - - | -
311 | -! | -
- ns <- NS(id)- |
-
312 | -! | -
- teal.widgets::standard_layout(- |
-
313 | -! | -
- output = teal.widgets::white_small_well(- |
-
314 | -! | -
- tags$div(teal.widgets::plot_with_settings_ui(id = ns("myplot")))- |
-
315 | -- |
- ),- |
-
316 | -! | -
- encoding = div(- |
-
317 | -- |
- ### Reporter- |
-
318 | -! | -
- teal.reporter::simple_reporter_ui(ns("simple_reporter")),- |
-
319 | -- |
- ###- |
-
320 | -! | -
- tags$label("Encodings", class = "text-primary"),- |
-
321 | -! | -
- teal.transform::datanames_input(args[c("x", "y", "row_facet", "col_facet", "color", "fill", "size")]),- |
-
322 | -! | -
- teal.transform::data_extract_ui(- |
-
323 | -! | -
- id = ns("x"),- |
-
324 | -! | -
- label = "X variable",- |
-
325 | -! | -
- data_extract_spec = args$x,- |
-
326 | -! | -
- is_single_dataset = is_single_dataset_value- |
-
327 | -- |
- ),- |
-
328 | -! | -
- teal.transform::data_extract_ui(- |
-
329 | -! | -
- id = ns("y"),- |
-
330 | -! | -
- label = "Y variable",- |
-
331 | -! | -
- data_extract_spec = args$y,- |
-
332 | -! | -
- is_single_dataset = is_single_dataset_value- |
-
333 | -- |
- ),- |
-
334 | -! | -
- conditionalPanel(- |
-
335 | -! | -
- condition =- |
-
336 | -! | -
- "$(\"button[data-id*='-x-dataset'][data-id$='-select']\").text() == '- Nothing selected - ' ||- |
-
337 | -! | -
- $(\"button[data-id*='-y-dataset'][data-id$='-select']\").text() == '- Nothing selected - ' ",- |
-
338 | -! | -
- shinyWidgets::radioGroupButtons(- |
-
339 | -! | -
- inputId = ns("use_density"),- |
-
340 | -! | -
- label = NULL,- |
-
341 | -! | -
- choices = c("frequency", "density"),- |
-
342 | -! | -
- selected = ifelse(args$use_density, "density", "frequency"),- |
-
343 | -! | -
- justified = TRUE- |
-
344 | -- |
- )- |
-
345 | -- |
- ),- |
-
346 | -! | -
- if (!is.null(args$row_facet) || !is.null(args$col_facet)) {- |
-
347 | -! | -
- div(- |
-
348 | -! | -
- class = "data-extract-box",- |
-
349 | -! | -
- tags$label("Facetting"),- |
-
350 | -! | -
- shinyWidgets::switchInput(inputId = ns("facetting"), value = args$facet, size = "mini"),- |
-
351 | -! | -
- conditionalPanel(- |
-
352 | -! | -
- condition = paste0("input['", ns("facetting"), "']"),- |
-
353 | -! | -
- div(- |
-
354 | -! | -
- if (!is.null(args$row_facet)) {- |
-
355 | -! | -
- teal.transform::data_extract_ui(- |
-
356 | -! | -
- id = ns("row_facet"),- |
-
357 | -! | -
- label = "Row facetting variable",- |
-
358 | -! | -
- data_extract_spec = args$row_facet,- |
-
359 | -! | -
- is_single_dataset = is_single_dataset_value- |
-
360 | -- |
- )- |
-
361 | -- |
- },- |
-
362 | -! | -
- if (!is.null(args$col_facet)) {- |
-
363 | -! | -
- teal.transform::data_extract_ui(- |
-
364 | -! | -
- id = ns("col_facet"),- |
-
365 | -! | -
- label = "Column facetting variable",- |
-
366 | -! | -
- data_extract_spec = args$col_facet,- |
-
367 | -! | -
- is_single_dataset = is_single_dataset_value- |
-
368 | -- |
- )- |
-
369 | -- |
- },- |
-
370 | -! | -
- checkboxInput(ns("free_x_scales"), "free x scales", value = args$free_x_scales),- |
-
371 | -! | -
- checkboxInput(ns("free_y_scales"), "free y scales", value = args$free_y_scales)- |
-
372 | -- |
- )- |
-
373 | -- |
- )- |
-
374 | -- |
- )- |
-
375 | -- |
- },- |
-
376 | -! | -
- if (args$color_settings) {- |
-
377 | -- |
- # Put a grey border around the coloring settings- |
-
378 | -! | -
- div(- |
-
379 | -! | -
- class = "data-extract-box",- |
-
380 | -! | -
- tags$label("Color settings"),- |
-
381 | -! | -
- shinyWidgets::switchInput(inputId = ns("coloring"), value = TRUE, size = "mini"),- |
-
382 | -! | -
- conditionalPanel(- |
-
383 | -! | -
- condition = paste0("input['", ns("coloring"), "']"),- |
-
384 | -! | -
- div(- |
-
385 | -! | -
- teal.transform::data_extract_ui(- |
-
386 | -! | -
- id = ns("color"),- |
-
387 | -! | -
- label = "Outline color by variable",- |
-
388 | -! | -
- data_extract_spec = args$color,- |
-
389 | -! | -
- is_single_dataset = is_single_dataset_value- |
-
390 | -- |
- ),- |
-
391 | -! | -
- teal.transform::data_extract_ui(- |
-
392 | -! | -
- id = ns("fill"),- |
-
393 | -! | -
- label = "Fill color by variable",- |
-
394 | -! | -
- data_extract_spec = args$fill,- |
-
395 | -! | -
- is_single_dataset = is_single_dataset_value- |
-
396 | -- |
- ),- |
-
397 | -! | -
- div(- |
-
398 | -! | -
- id = ns("size_settings"),- |
-
399 | -! | -
- teal.transform::data_extract_ui(- |
-
400 | -! | -
- id = ns("size"),- |
-
401 | -! | -
- label = "Size of points by variable (only if x and y are numeric)",- |
-
402 | -! | -
- data_extract_spec = args$size,- |
-
403 | -! | -
- is_single_dataset = is_single_dataset_value- |
-
404 | -- |
- )- |
-
405 | -- |
- )- |
-
406 | -- |
- )- |
-
407 | -- |
- )- |
-
408 | -- |
- )- |
-
409 | -- |
- },- |
-
410 | -! | -
- teal.widgets::panel_group(- |
-
411 | -! | -
- teal.widgets::panel_item(- |
-
412 | -! | -
- title = "Plot settings",- |
-
413 | -! | -
- checkboxInput(ns("rotate_xaxis_labels"), "Rotate X axis labels", value = args$rotate_xaxis_labels),- |
-
414 | -! | -
- checkboxInput(ns("swap_axes"), "Swap axes", value = args$swap_axes),- |
-
415 | -! | -
- selectInput(- |
-
416 | -! | -
- inputId = ns("ggtheme"),- |
-
417 | -! | -
- label = "Theme (by ggplot):",- |
-
418 | -! | -
- choices = ggplot_themes,- |
-
419 | -! | -
- selected = args$ggtheme,- |
-
420 | -! | -
- multiple = FALSE- |
-
421 | -- |
- ),- |
-
422 | -! | -
- sliderInput(- |
-
423 | -! | -
- ns("alpha"), "Opacity Scatterplot:",- |
-
424 | -! | -
- min = 0, max = 1,- |
-
425 | -! | -
- step = .05, value = .5, ticks = FALSE- |
-
426 | -- |
- ),- |
-
427 | -! | -
- sliderInput(- |
-
428 | -! | -
- ns("fixed_size"), "Scatterplot point size:",- |
-
429 | -! | -
- min = 1, max = 8,- |
-
430 | -! | -
- step = 1, value = 2, ticks = FALSE- |
-
431 | -- |
- ),- |
-
432 | -! | -
- checkboxInput(ns("add_lines"), "Add lines"),- |
-
433 | -- |
- )- |
-
434 | -- |
- )- |
-
435 | -- |
- ),- |
-
436 | -! | -
- forms = tagList(- |
-
437 | -! | -
- teal.widgets::verbatim_popup_ui(ns("warning"), button_label = "Show Warnings"),- |
-
438 | -! | -
- teal.widgets::verbatim_popup_ui(ns("rcode"), "Show R code")- |
-
439 | -- |
- ),- |
-
440 | -! | -
- pre_output = args$pre_output,- |
-
441 | -! | -
- post_output = args$post_output- |
-
442 | -- |
- )- |
-
443 | -- |
- }- |
-
444 | -- | - - | -
445 | -- |
- # Server function for the bivariate module- |
-
446 | -- |
- srv_g_bivariate <- function(id,- |
-
447 | -- |
- data,- |
-
448 | -- |
- reporter,- |
-
449 | -- |
- filter_panel_api,- |
-
450 | -- |
- x,- |
-
451 | -- |
- y,- |
-
452 | -- |
- row_facet,- |
-
453 | -- |
- col_facet,- |
-
454 | -- |
- color_settings = FALSE,- |
-
455 | -- |
- color,- |
-
456 | -- |
- fill,- |
-
457 | -- |
- size,- |
-
458 | -- |
- plot_height,- |
-
459 | -- |
- plot_width,- |
-
460 | -- |
- ggplot2_args) {- |
-
461 | -! | -
- with_reporter <- !missing(reporter) && inherits(reporter, "Reporter")- |
-
462 | -! | -
- with_filter <- !missing(filter_panel_api) && inherits(filter_panel_api, "FilterPanelAPI")- |
-
463 | -! | -
- checkmate::assert_class(data, "reactive")- |
-
464 | -! | -
- checkmate::assert_class(isolate(data()), "teal_data")- |
-
465 | -! | -
- moduleServer(id, function(input, output, session) {- |
-
466 | -! | -
- data_extract <- list(- |
-
467 | -! | -
- x = x, y = y, row_facet = row_facet, col_facet = col_facet,- |
-
468 | -! | -
- color = color, fill = fill, size = size- |
-
469 | -- |
- )- |
-
470 | -- | - - | -
471 | -! | -
- rule_var <- function(other) {- |
-
472 | -! | -
- function(value) {- |
-
473 | -! | -
- othervalue <- selector_list()[[other]]()$select- |
-
474 | -! | -
- if (length(value) == 0L && length(othervalue) == 0L) {- |
-
475 | -! | -
- "Please select at least one of x-variable or y-variable"- |
-
476 | -- |
- }- |
-
477 | -- |
- }- |
-
478 | -- |
- }- |
-
479 | -! | -
- rule_diff <- function(other) {- |
-
480 | -! | -
- function(value) {- |
-
481 | -! | -
- othervalue <- selector_list()[[other]]()[["select"]]- |
-
482 | -! | -
- if (!is.null(othervalue)) {- |
-
483 | -! | -
- if (identical(value, othervalue)) {- |
-
484 | -! | -
- "Row and column facetting variables must be different."- |
-
485 | -- |
- }- |
-
486 | -- |
- }- |
-
487 | -- |
- }- |
-
488 | -- |
- }- |
-
489 | -- | - - | -
490 | -! | -
- selector_list <- teal.transform::data_extract_multiple_srv(- |
-
491 | -! | -
- data_extract = data_extract,- |
-
492 | -! | -
- datasets = data,- |
-
493 | -! | -
- select_validation_rule = list(- |
-
494 | -! | -
- x = rule_var("y"),- |
-
495 | -! | -
- y = rule_var("x"),- |
-
496 | -! | -
- row_facet = shinyvalidate::compose_rules(- |
-
497 | -! | -
- shinyvalidate::sv_optional(),- |
-
498 | -! | -
- rule_diff("col_facet")- |
-
499 | -- |
- ),- |
-
500 | -! | -
- col_facet = shinyvalidate::compose_rules(- |
-
501 | -! | -
- shinyvalidate::sv_optional(),- |
-
502 | -! | -
- rule_diff("row_facet")- |
-
503 | -- |
- )- |
-
504 | -- |
- )- |
-
505 | -- |
- )- |
-
506 | -- | - - | -
507 | -! | -
- iv_r <- reactive({- |
-
508 | -! | -
- iv_facet <- shinyvalidate::InputValidator$new()- |
-
509 | -! | -
- iv_child <- teal.transform::compose_and_enable_validators(iv_facet, selector_list,- |
-
510 | -! | -
- validator_names = c("row_facet", "col_facet")- |
-
511 | -- |
- )- |
-
512 | -! | -
- iv_child$condition(~ isTRUE(input$facetting))- |
-
513 | -- | - - | -
514 | -! | -
- iv <- shinyvalidate::InputValidator$new()- |
-
515 | -! | -
- iv$add_validator(iv_child)- |
-
516 | -! | -
- teal.transform::compose_and_enable_validators(iv, selector_list, validator_names = c("x", "y"))- |
-
517 | -- |
- })- |
-
518 | -- | - - | -
519 | -! | -
- anl_merged_input <- teal.transform::merge_expression_srv(- |
-
520 | -! | -
- selector_list = selector_list,- |
-
521 | -! | -
- datasets = data- |
-
522 | -- |
- )- |
-
523 | -- | - - | -
524 | -! | -
- anl_merged_q <- reactive({- |
-
525 | -! | -
- req(anl_merged_input())- |
-
526 | -! | -
- data() %>%- |
-
527 | -! | -
- teal.code::eval_code(as.expression(anl_merged_input()$expr))- |
-
528 | -- |
- })- |
-
529 | -- | - - | -
530 | -! | -
- merged <- list(- |
-
531 | -! | -
- anl_input_r = anl_merged_input,- |
-
532 | -! | -
- anl_q_r = anl_merged_q- |
-
533 | -- |
- )- |
-
534 | -- | - - | -
535 | -! | -
- output_q <- reactive({- |
-
536 | -! | -
- teal::validate_inputs(iv_r())- |
-
537 | -- | - - | -
538 | -! | -
- ANL <- merged$anl_q_r()[["ANL"]]- |
-
539 | -! | -
- teal::validate_has_data(ANL, 3)- |
-
540 | -- | - - | -
541 | -! | -
- x_col_vec <- as.vector(merged$anl_input_r()$columns_source$x)- |
-
542 | -! | -
- x_name <- `if`(is.null(x_col_vec), character(0), x_col_vec)- |
-
543 | -! | -
- y_col_vec <- as.vector(merged$anl_input_r()$columns_source$y)- |
-
544 | -! | -
- y_name <- `if`(is.null(y_col_vec), character(0), y_col_vec)- |
-
545 | -- | - - | -
546 | -! | -
- row_facet_name <- as.vector(merged$anl_input_r()$columns_source$row_facet)- |
-
547 | -! | -
- col_facet_name <- as.vector(merged$anl_input_r()$columns_source$col_facet)- |
-
548 | -! | -
- color_name <- if ("color" %in% names(merged$anl_input_r()$columns_source)) {- |
-
549 | -! | -
- as.vector(merged$anl_input_r()$columns_source$color)- |
-
550 | -- |
- } else {- |
-
551 | -! | -
- character(0)- |
-
552 | -- |
- }- |
-
553 | -! | -
- fill_name <- if ("fill" %in% names(merged$anl_input_r()$columns_source)) {- |
-
554 | -! | -
- as.vector(merged$anl_input_r()$columns_source$fill)- |
-
555 | -- |
- } else {- |
-
556 | -! | -
- character(0)- |
-
557 | -- |
- }- |
-
558 | -! | -
- size_name <- if ("size" %in% names(merged$anl_input_r()$columns_source)) {- |
-
559 | -! | -
- as.vector(merged$anl_input_r()$columns_source$size)- |
-
560 | -- |
- } else {- |
-
561 | -! | -
- character(0)- |
-
562 | -- |
- }- |
-
563 | -- | - - | -
564 | -! | -
- use_density <- input$use_density == "density"- |
-
565 | -! | -
- free_x_scales <- input$free_x_scales- |
-
566 | -! | -
- free_y_scales <- input$free_y_scales- |
-
567 | -! | -
- ggtheme <- input$ggtheme- |
-
568 | -! | -
- rotate_xaxis_labels <- input$rotate_xaxis_labels- |
-
569 | -! | -
- swap_axes <- input$swap_axes- |
-
570 | -- | - - | -
571 | -! | -
- is_scatterplot <- all(vapply(ANL[c(x_name, y_name)], is.numeric, logical(1))) &&- |
-
572 | -! | -
- length(x_name) > 0 && length(y_name) > 0- |
-
573 | -- | - - | -
574 | -! | -
- if (is_scatterplot) {- |
-
575 | -! | -
- shinyjs::show("alpha")- |
-
576 | -! | -
- alpha <- input$alpha- |
-
577 | -! | -
- shinyjs::show("add_lines")- |
-
578 | -- | - - | -
579 | -! | -
- if (color_settings && input$coloring) {- |
-
580 | -! | -
- shinyjs::hide("fixed_size")- |
-
581 | -! | -
- shinyjs::show("size_settings")- |
-
582 | -! | -
- size <- NULL- |
-
583 | -- |
- } else {- |
-
584 | -! | -
- shinyjs::show("fixed_size")- |
-
585 | -! | -
- size <- input$fixed_size- |
-
586 | -- |
- }- |
-
587 | -- |
- } else {- |
-
588 | -! | -
- shinyjs::hide("add_lines")- |
-
589 | -! | -
- updateCheckboxInput(session, "add_lines", value = FALSE)- |
-
590 | -! | -
- shinyjs::hide("alpha")- |
-
591 | -! | -
- shinyjs::hide("fixed_size")- |
-
592 | -! | -
- shinyjs::hide("size_settings")- |
-
593 | -! | -
- alpha <- 1- |
-
594 | -! | -
- size <- NULL- |
-
595 | -- |
- }- |
-
596 | -- | - - | -
597 | -! | -
- teal::validate_has_data(ANL[, c(x_name, y_name), drop = FALSE], 3, complete = TRUE, allow_inf = FALSE)- |
-
598 | -- | - - | -
599 | -! | -
- cl <- bivariate_plot_call(- |
-
600 | -! | -
- data_name = "ANL",- |
-
601 | -! | -
- x = x_name,- |
-
602 | -! | -
- y = y_name,- |
-
603 | -! | -
- x_class = ifelse(!identical(x_name, character(0)), class(ANL[[x_name]]), "NULL"),- |
-
604 | -! | -
- y_class = ifelse(!identical(y_name, character(0)), class(ANL[[y_name]]), "NULL"),- |
-
605 | -! | -
- x_label = varname_w_label(x_name, ANL),- |
-
606 | -! | -
- y_label = varname_w_label(y_name, ANL),- |
-
607 | -! | -
- freq = !use_density,- |
-
608 | -! | -
- theme = ggtheme,- |
-
609 | -! | -
- rotate_xaxis_labels = rotate_xaxis_labels,- |
-
610 | -! | -
- swap_axes = swap_axes,- |
-
611 | -! | -
- alpha = alpha,- |
-
612 | -! | -
- size = size,- |
-
613 | -! | -
- ggplot2_args = ggplot2_args- |
-
614 | -- |
- )- |
-
615 | -- | - - | -
616 | -! | -
- facetting <- (isTRUE(input$facetting) && (!is.null(row_facet_name) || !is.null(col_facet_name)))- |
-
617 | -- | - - | -
618 | -! | -
- if (facetting) {- |
-
619 | -! | -
- facet_cl <- facet_ggplot_call(row_facet_name, col_facet_name, free_x_scales, free_y_scales)- |
-
620 | -- | - - | -
621 | -! | -
- if (!is.null(facet_cl)) {- |
-
622 | -! | -
- cl <- call("+", cl, facet_cl)- |
-
623 | -- |
- }- |
-
624 | -- |
- }- |
-
625 | -- | - - | -
626 | -! | -
- if (input$add_lines) {- |
-
627 | -! | -
- cl <- call("+", cl, quote(geom_line(size = 1)))- |
-
628 | -- |
- }- |
-
629 | -- | - - | -
630 | -! | -
- coloring_cl <- NULL- |
-
631 | -! | -
- if (color_settings) {- |
-
632 | -! | -
- if (input$coloring) {- |
-
633 | -! | -
- coloring_cl <- coloring_ggplot_call(- |
-
634 | -! | -
- colour = color_name,- |
-
635 | -! | -
- fill = fill_name,- |
-
636 | -! | -
- size = size_name,- |
-
637 | -! | -
- is_point = any(grepl("geom_point", cl %>% deparse()))- |
-
638 | -- |
- )- |
-
639 | -! | -
- legend_lbls <- substitute(- |
-
640 | -! | -
- expr = labs(color = color_name, fill = fill_name, size = size_name),- |
-
641 | -! | -
- env = list(- |
-
642 | -! | -
- color_name = varname_w_label(color_name, ANL),- |
-
643 | -! | -
- fill_name = varname_w_label(fill_name, ANL),- |
-
644 | -! | -
- size_name = varname_w_label(size_name, ANL)- |
-
645 | -- |
- )- |
-
646 | -- |
- )- |
-
647 | -- |
- }- |
-
648 | -! | -
- if (!is.null(coloring_cl)) {- |
-
649 | -! | -
- cl <- call("+", call("+", cl, coloring_cl), legend_lbls)- |
-
650 | -- |
- }- |
-
651 | -- |
- }- |
-
652 | -- | - - | -
653 | -- |
- # Add labels to facets- |
-
654 | -! | -
- nulled_row_facet_name <- varname_w_label(row_facet_name, ANL)- |
-
655 | -! | -
- nulled_col_facet_name <- varname_w_label(col_facet_name, ANL)- |
-
656 | -! | -
- without_facet <- (is.null(nulled_row_facet_name) && is.null(nulled_col_facet_name)) || !facetting- |
-
657 | -- | - - | -
658 | -! | -
- print_call <- if (without_facet) {- |
-
659 | -! | -
- quote(print(p))- |
-
660 | -- |
- } else {- |
-
661 | -! | -
- substitute(- |
-
662 | -! | -
- expr = {- |
-
663 | -- |
- # Add facetting labels- |
-
664 | -- |
- # optional: grid.newpage() # nolint: commented_code.- |
-
665 | -! | -
- p <- add_facet_labels(p, xfacet_label = nulled_col_facet_name, yfacet_label = nulled_row_facet_name)- |
-
666 | -! | -
- grid::grid.newpage()- |
-
667 | -! | -
- grid::grid.draw(p)- |
-
668 | -- |
- },- |
-
669 | -! | -
- env = list(nulled_col_facet_name = nulled_col_facet_name, nulled_row_facet_name = nulled_row_facet_name)- |
-
670 | -- |
- )- |
-
671 | -- |
- }- |
-
672 | -- | - - | -
673 | -! | -
- teal.code::eval_code(merged$anl_q_r(), substitute(expr = p <- cl, env = list(cl = cl))) %>%- |
-
674 | -! | -
- teal.code::eval_code(print_call)- |
-
675 | -- |
- })- |
-
676 | -- | - - | -
677 | -! | -
- plot_r <- shiny::reactive({- |
-
678 | -! | -
- output_q()[["p"]]- |
-
679 | -- |
- })- |
-
680 | -- | - - | -
681 | -! | -
- pws <- teal.widgets::plot_with_settings_srv(- |
-
682 | -! | -
- id = "myplot",- |
-
683 | -! | -
- plot_r = plot_r,- |
-
684 | -! | -
- height = plot_height,- |
-
685 | -! | -
- width = plot_width- |
-
686 | -- |
- )- |
-
687 | -- | - - | -
688 | -! | -
- teal.widgets::verbatim_popup_srv(- |
-
689 | -! | -
- id = "warning",- |
-
690 | -! | -
- verbatim_content = reactive(teal.code::get_warnings(output_q())),- |
-
691 | -! | -
- title = "Warning",- |
-
692 | -! | -
- disabled = reactive(is.null(teal.code::get_warnings(output_q())))- |
-
693 | -- |
- )- |
-
694 | -- | - - | -
695 | -! | -
- teal.widgets::verbatim_popup_srv(- |
-
696 | -! | -
- id = "rcode",- |
-
697 | -! | -
- verbatim_content = reactive(teal.code::get_code(output_q())),- |
-
698 | -! | -
- title = "Bivariate Plot"- |
-
699 | -- |
- )- |
-
700 | -- | - - | -
701 | -- |
- ### REPORTER- |
-
702 | -! | -
- if (with_reporter) {- |
-
703 | -! | -
- card_fun <- function(comment, label) {- |
-
704 | -! | -
- card <- teal::report_card_template(- |
-
705 | -! | -
- title = "Bivariate Plot",- |
-
706 | -! | -
- label = label,- |
-
707 | -! | -
- with_filter = with_filter,- |
-
708 | -! | -
- filter_panel_api = filter_panel_api- |
-
709 | -- |
- )- |
-
710 | -! | -
- card$append_text("Plot", "header3")- |
-
711 | -! | -
- card$append_plot(plot_r(), dim = pws$dim())- |
-
712 | -! | -
- if (!comment == "") {- |
-
713 | -! | -
- card$append_text("Comment", "header3")- |
-
714 | -! | -
- card$append_text(comment)- |
-
715 | -- |
- }- |
-
716 | -! | -
- card$append_src(teal.code::get_code(output_q()))- |
-
717 | -! | -
- card- |
-
718 | -- |
- }- |
-
719 | -! | -
- teal.reporter::simple_reporter_srv("simple_reporter", reporter = reporter, card_fun = card_fun)- |
-
720 | -- |
- }- |
-
721 | -- |
- ###- |
-
722 | -- |
- })- |
-
723 | -- |
- }- |
-
724 | -- | - - | -
725 | -- |
- # Get Substituted ggplot call- |
-
726 | -- |
- bivariate_plot_call <- function(data_name,- |
-
727 | -- |
- x = character(0),- |
-
728 | -- |
- y = character(0),- |
-
729 | -- |
- x_class = "NULL",- |
-
730 | -- |
- y_class = "NULL",- |
-
731 | -- |
- x_label = NULL,- |
-
732 | -- |
- y_label = NULL,- |
-
733 | -- |
- freq = TRUE,- |
-
734 | -- |
- theme = "gray",- |
-
735 | -- |
- rotate_xaxis_labels = FALSE,- |
-
736 | -- |
- swap_axes = FALSE,- |
-
737 | -- |
- alpha = double(0),- |
-
738 | -- |
- size = 2,- |
-
739 | -- |
- ggplot2_args = teal.widgets::ggplot2_args()) {- |
-
740 | -! | -
- supported_types <- c("NULL", "numeric", "integer", "factor", "character", "logical", "ordered")- |
-
741 | -! | -
- validate(need(x_class %in% supported_types, paste0("Data type '", x_class, "' is not supported.")))- |
-
742 | -! | -
- validate(need(y_class %in% supported_types, paste0("Data type '", y_class, "' is not supported.")))- |
-
743 | -- | - - | -
744 | -- | - - | -
745 | -! | -
- if (identical(x, character(0))) {- |
-
746 | -! | -
- x <- x_label <- "-"- |
-
747 | -- |
- } else {- |
-
748 | -! | -
- x <- if (is.call(x)) x else as.name(x)- |
-
749 | -- |
- }- |
-
750 | -! | -
- if (identical(y, character(0))) {- |
-
751 | -! | -
- y <- y_label <- "-"- |
-
752 | -- |
- } else {- |
-
753 | -! | -
- y <- if (is.call(y)) y else as.name(y)- |
-
754 | -- |
- }- |
-
755 | -- | - - | -
756 | -! | -
- cl <- bivariate_ggplot_call(- |
-
757 | -! | -
- x_class = x_class,- |
-
758 | -! | -
- y_class = y_class,- |
-
759 | -! | -
- freq = freq,- |
-
760 | -! | -
- theme = theme,- |
-
761 | -! | -
- rotate_xaxis_labels = rotate_xaxis_labels,- |
-
762 | -! | -
- swap_axes = swap_axes,- |
-
763 | -! | -
- alpha = alpha,- |
-
764 | -! | -
- size = size,- |
-
765 | -! | -
- ggplot2_args = ggplot2_args,- |
-
766 | -! | -
- x = x,- |
-
767 | -! | -
- y = y,- |
-
768 | -! | -
- xlab = x_label,- |
-
769 | -! | -
- ylab = y_label,- |
-
770 | -! | -
- data_name = data_name- |
-
771 | -- |
- )- |
-
772 | -- |
- }- |
-
773 | -- | - - | -
774 | -- |
- # Create ggplot part of plot call- |
-
775 | -- |
- # Due to the type of the x and y variable the plot type is chosen- |
-
776 | -- |
- bivariate_ggplot_call <- function(x_class,- |
-
777 | -- |
- y_class,- |
-
778 | -- |
- freq = TRUE,- |
-
779 | -- |
- theme = "gray",- |
-
780 | -- |
- rotate_xaxis_labels = FALSE,- |
-
781 | -- |
- swap_axes = FALSE,- |
-
782 | -- |
- size = double(0),- |
-
783 | -- |
- alpha = double(0),- |
-
784 | -- |
- x = NULL,- |
-
785 | -- |
- y = NULL,- |
-
786 | -- |
- xlab = "-",- |
-
787 | -- |
- ylab = "-",- |
-
788 | -- |
- data_name = "ANL",- |
-
789 | -- |
- ggplot2_args = teal.widgets::ggplot2_args()) {- |
-
790 | -42x | -
- x_class <- switch(x_class,- |
-
791 | -42x | -
- "character" = ,- |
-
792 | -42x | -
- "ordered" = ,- |
-
793 | -42x | -
- "logical" = ,- |
-
794 | -42x | -
- "factor" = "factor",- |
-
795 | -42x | -
- "integer" = ,- |
-
796 | -42x | -
- "numeric" = "numeric",- |
-
797 | -42x | -
- "NULL" = "NULL",- |
-
798 | -42x | -
- stop("unsupported x_class: ", x_class)- |
-
799 | -- |
- )- |
-
800 | -42x | -
- y_class <- switch(y_class,- |
-
801 | -42x | -
- "character" = ,- |
-
802 | -42x | -
- "ordered" = ,- |
-
803 | -42x | -
- "logical" = ,- |
-
804 | -42x | -
- "factor" = "factor",- |
-
805 | -42x | -
- "integer" = ,- |
-
806 | -42x | -
- "numeric" = "numeric",- |
-
807 | -42x | -
- "NULL" = "NULL",- |
-
808 | -42x | -
- stop("unsupported y_class: ", y_class)- |
-
809 | -- |
- )- |
-
810 | -- | - - | -
811 | -42x | -
- if (all(c(x_class, y_class) == "NULL")) {- |
-
812 | -! | -
- stop("either x or y is required")- |
-
813 | -- |
- }- |
-
814 | -- | - - | -
815 | -42x | -
- reduce_plot_call <- function(...) {- |
-
816 | -104x | -
- args <- Filter(Negate(is.null), list(...))- |
-
817 | -104x | -
- Reduce(function(x, y) call("+", x, y), args)- |
-
818 | -- |
- }- |
-
819 | -- | - - | -
820 | -42x | -
- plot_call <- substitute(ggplot(data_name), env = list(data_name = as.name(data_name)))- |
-
821 | -- | - - | -
822 | -- |
- # Single data plots- |
-
823 | -42x | -
- if (x_class == "numeric" && y_class == "NULL") {- |
-
824 | -6x | -
- plot_call <- reduce_plot_call(plot_call, substitute(aes(x = xval), env = list(xval = x)))- |
-
825 | -- | - - | -
826 | -6x | -
- if (freq) {- |
-
827 | -4x | -
- plot_call <- reduce_plot_call(- |
-
828 | -4x | -
- plot_call,- |
-
829 | -4x | -
- quote(geom_histogram(bins = 30)),- |
-
830 | -4x | -
- quote(ylab("Frequency"))- |
-
831 | -- |
- )- |
-
832 | -- |
- } else {- |
-
833 | -2x | -
- plot_call <- reduce_plot_call(- |
-
834 | -2x | -
- plot_call,- |
-
835 | -2x | -
- quote(geom_histogram(bins = 30, aes(y = after_stat(density)))),- |
-
836 | -2x | -
- quote(geom_density(aes(y = after_stat(density)))),- |
-
837 | -2x | -
- quote(ylab("Density"))- |
-
838 | -- |
- )- |
-
839 | -- |
- }- |
-
840 | -36x | -
- } else if (x_class == "NULL" && y_class == "numeric") {- |
-
841 | -6x | -
- plot_call <- reduce_plot_call(plot_call, substitute(aes(x = yval), env = list(yval = y)))- |
-
842 | -- | - - | -
843 | -6x | -
- if (freq) {- |
-
844 | -4x | -
- plot_call <- reduce_plot_call(- |
-
845 | -4x | -
- plot_call,- |
-
846 | -4x | -
- quote(geom_histogram(bins = 30)),- |
-
847 | -4x | -
- quote(ylab("Frequency"))- |
-
848 | -- |
- )- |
-
849 | -- |
- } else {- |
-
850 | -2x | -
- plot_call <- reduce_plot_call(- |
-
851 | -2x | -
- plot_call,- |
-
852 | -2x | -
- quote(geom_histogram(bins = 30, aes(y = after_stat(density)))),- |
-
853 | -2x | -
- quote(geom_density(aes(y = after_stat(density)))),- |
-
854 | -2x | -
- quote(ylab("Density"))- |
-
855 | -- |
- )- |
-
856 | -- |
- }- |
-
857 | -30x | -
- } else if (x_class == "factor" && y_class == "NULL") {- |
-
858 | -4x | -
- plot_call <- reduce_plot_call(plot_call, substitute(aes(x = xval), env = list(xval = x)))- |
-
859 | -- | - - | -
860 | -4x | -
- if (freq) {- |
-
861 | -2x | -
- plot_call <- reduce_plot_call(- |
-
862 | -2x | -
- plot_call,- |
-
863 | -2x | -
- quote(geom_bar()),- |
-
864 | -2x | -
- quote(ylab("Frequency"))- |
-
865 | -- |
- )- |
-
866 | -- |
- } else {- |
-
867 | -2x | -
- plot_call <- reduce_plot_call(- |
-
868 | -2x | -
- plot_call,- |
-
869 | -2x | -
- quote(geom_bar(aes(y = after_stat(prop), group = 1))),- |
-
870 | -2x | -
- quote(ylab("Fraction"))- |
-
871 | -- |
- )- |
-
872 | -- |
- }- |
-
873 | -26x | -
- } else if (x_class == "NULL" && y_class == "factor") {- |
-
874 | -4x | -
- plot_call <- reduce_plot_call(plot_call, substitute(aes(x = yval), env = list(yval = y)))- |
-
875 | -- | - - | -
876 | -4x | -
- if (freq) {- |
-
877 | -2x | -
- plot_call <- reduce_plot_call(- |
-
878 | -2x | -
- plot_call,- |
-
879 | -2x | -
- quote(geom_bar()),- |
-
880 | -2x | -
- quote(ylab("Frequency"))- |
-
881 | -- |
- )- |
-
882 | -- |
- } else {- |
-
883 | -2x | -
- plot_call <- reduce_plot_call(- |
-
884 | -2x | -
- plot_call,- |
-
885 | -2x | -
- quote(geom_bar(aes(y = after_stat(prop), group = 1))),- |
-
886 | -2x | -
- quote(ylab("Fraction"))- |
-
887 | -- |
- )- |
-
888 | -- |
- }- |
-
889 | -- |
- # Numeric Plots- |
-
890 | -22x | -
- } else if (x_class == "numeric" && y_class == "numeric") {- |
-
891 | -2x | -
- plot_call <- reduce_plot_call(- |
-
892 | -2x | -
- plot_call,- |
-
893 | -2x | -
- substitute(aes(x = xval, y = yval), env = list(xval = x, yval = y)),- |
-
894 | -- |
- # pch = 21 for consistent coloring behaviour b/w all geoms (outline and fill properties)- |
-
895 | -2x | -
- `if`(- |
-
896 | -2x | -
- !is.null(size),- |
-
897 | -2x | -
- substitute(- |
-
898 | -2x | -
- geom_point(alpha = alphaval, size = sizeval, pch = 21),- |
-
899 | -2x | -
- env = list(alphaval = alpha, sizeval = size)- |
-
900 | -- |
- ),- |
-
901 | -2x | -
- substitute(- |
-
902 | -2x | -
- geom_point(alpha = alphaval, pch = 21),- |
-
903 | -2x | -
- env = list(alphaval = alpha)- |
-
904 | -- |
- )- |
-
905 | -- |
- )- |
-
906 | -- |
- )- |
-
907 | -20x | -
- } else if ((x_class == "numeric" && y_class == "factor") || (x_class == "factor" && y_class == "numeric")) {- |
-
908 | -6x | -
- plot_call <- reduce_plot_call(- |
-
909 | -6x | -
- plot_call,- |
-
910 | -6x | -
- substitute(aes(x = xval, y = yval), env = list(xval = x, yval = y)),- |
-
911 | -6x | -
- quote(geom_boxplot())- |
-
912 | -- |
- )- |
-
913 | -- |
- # Factor and character plots- |
-
914 | -14x | -
- } else if (x_class == "factor" && y_class == "factor") {- |
-
915 | -14x | -
- plot_call <- reduce_plot_call(- |
-
916 | -14x | -
- plot_call,- |
-
917 | -14x | -
- substitute(- |
-
918 | -14x | -
- ggmosaic::geom_mosaic(aes(x = ggmosaic::product(xval), fill = yval), na.rm = TRUE),- |
-
919 | -14x | -
- env = list(xval = x, yval = y)- |
-
920 | -- |
- )- |
-
921 | -- |
- )- |
-
922 | -- |
- } else {- |
-
923 | -! | -
- stop("x y type combination not allowed")- |
-
924 | -- |
- }- |
-
925 | -- | - - | -
926 | -42x | -
- labs_base <- if (x_class == "NULL") {- |
-
927 | -10x | -
- list(x = substitute(ylab, list(ylab = ylab)))- |
-
928 | -42x | -
- } else if (y_class == "NULL") {- |
-
929 | -10x | -
- list(x = substitute(xlab, list(xlab = xlab)))- |
-
930 | -- |
- } else {- |
-
931 | -22x | -
- list(- |
-
932 | -22x | -
- x = substitute(xlab, list(xlab = xlab)),- |
-
933 | -22x | -
- y = substitute(ylab, list(ylab = ylab))- |
-
934 | -- |
- )- |
-
935 | -- |
- }- |
-
936 | -- | - - | -
937 | -42x | -
- dev_ggplot2_args <- teal.widgets::ggplot2_args(labs = labs_base)- |
-
938 | -- | - - | -
939 | -42x | -
- if (rotate_xaxis_labels) {- |
-
940 | -! | -
- dev_ggplot2_args$theme <- list(axis.text.x = quote(element_text(angle = 45, hjust = 1)))- |
-
941 | -- |
- }- |
-
942 | -- | - - | -
943 | -42x | -
- all_ggplot2_args <- teal.widgets::resolve_ggplot2_args(- |
-
944 | -42x | -
- user_plot = ggplot2_args,- |
-
945 | -42x | -
- module_plot = dev_ggplot2_args- |
-
946 | -- |
- )- |
-
947 | -- | - - | -
948 | -42x | -
- parsed_ggplot2_args <- teal.widgets::parse_ggplot2_args(all_ggplot2_args, ggtheme = theme)- |
-
949 | -- | - - | -
950 | -42x | -
- plot_call <- reduce_plot_call(- |
-
951 | -42x | -
- plot_call,- |
-
952 | -42x | -
- parsed_ggplot2_args$labs,- |
-
953 | -42x | -
- parsed_ggplot2_args$ggtheme,- |
-
954 | -42x | -
- parsed_ggplot2_args$theme- |
-
955 | -- |
- )- |
-
956 | -- | - - | -
957 | -42x | -
- if (swap_axes) {- |
-
958 | -! | -
- plot_call <- reduce_plot_call(plot_call, quote(coord_flip()))- |
-
959 | -- |
- }- |
-
960 | -- | - - | -
961 | -42x | -
- plot_call- |
-
962 | -- |
- }- |
-
963 | -- | - - | -
964 | -- |
- # Create facet call- |
-
965 | -- |
- facet_ggplot_call <- function(row_facet = character(0),- |
-
966 | -- |
- col_facet = character(0),- |
-
967 | -- |
- free_x_scales = FALSE,- |
-
968 | -- |
- free_y_scales = FALSE) {- |
-
969 | -! | -
- scales <- if (free_x_scales && free_y_scales) {- |
-
970 | -! | -
- "free"- |
-
971 | -! | -
- } else if (free_x_scales) {- |
-
972 | -! | -
- "free_x"- |
-
973 | -! | -
- } else if (free_y_scales) {- |
-
974 | -! | -
- "free_y"- |
-
975 | -- |
- } else {- |
-
976 | -! | -
- "fixed"- |
-
977 | -- |
- }- |
-
978 | -- | - - | -
979 | -! | -
- if (identical(row_facet, character(0)) && identical(col_facet, character(0))) {- |
-
980 | -! | -
- NULL- |
-
981 | -! | -
- } else if (!identical(row_facet, character(0)) && !identical(col_facet, character(0))) {- |
-
982 | -! | -
- call(- |
-
983 | -! | -
- "facet_grid",- |
-
984 | -! | -
- rows = call_fun_dots("vars", row_facet),- |
-
985 | -! | -
- cols = call_fun_dots("vars", col_facet),- |
-
986 | -! | -
- scales = scales- |
-
987 | -- |
- )- |
-
988 | -! | -
- } else if (identical(row_facet, character(0)) && !identical(col_facet, character(0))) {- |
-
989 | -! | -
- call("facet_grid", cols = call_fun_dots("vars", col_facet), scales = scales)- |
-
990 | -! | -
- } else if (!identical(row_facet, character(0)) && identical(col_facet, character(0))) {- |
-
991 | -! | -
- call("facet_grid", rows = call_fun_dots("vars", row_facet), scales = scales)- |
-
992 | -- |
- }- |
-
993 | -- |
- }- |
-
994 | -- | - - | -
995 | -- |
- coloring_ggplot_call <- function(colour,- |
-
996 | -- |
- fill,- |
-
997 | -- |
- size,- |
-
998 | -- |
- is_point = FALSE) {- |
-
999 | -- |
- if (- |
-
1000 | -15x | -
- !identical(colour, character(0)) &&- |
-
1001 | -15x | -
- !identical(fill, character(0)) &&- |
-
1002 | -15x | -
- is_point &&- |
-
1003 | -15x | -
- !identical(size, character(0))- |
-
1004 | -- |
- ) {- |
-
1005 | -1x | -
- substitute(- |
-
1006 | -1x | -
- expr = aes(colour = colour_name, fill = fill_name, size = size_name),- |
-
1007 | -1x | -
- env = list(colour_name = as.name(colour), fill_name = as.name(fill), size_name = as.name(size))- |
-
1008 | -- |
- )- |
-
1009 | -- |
- } else if (- |
-
1010 | -14x | -
- identical(colour, character(0)) &&- |
-
1011 | -14x | -
- !identical(fill, character(0)) &&- |
-
1012 | -14x | -
- is_point &&- |
-
1013 | -14x | -
- identical(size, character(0))- |
-
1014 | -- |
- ) {- |
-
1015 | -1x | -
- substitute(expr = aes(fill = fill_name), env = list(fill_name = as.name(fill)))- |
-
1016 | -- |
- } else if (- |
-
1017 | -13x | -
- !identical(colour, character(0)) &&- |
-
1018 | -13x | -
- !identical(fill, character(0)) &&- |
-
1019 | -13x | -
- (!is_point || identical(size, character(0)))- |
-
1020 | -- |
- ) {- |
-
1021 | -3x | -
- substitute(- |
-
1022 | -3x | -
- expr = aes(colour = colour_name, fill = fill_name),- |
-
1023 | -3x | -
- env = list(colour_name = as.name(colour), fill_name = as.name(fill))- |
-
1024 | -- |
- )- |
-
1025 | -- |
- } else if (- |
-
1026 | -10x | -
- !identical(colour, character(0)) &&- |
-
1027 | -10x | -
- identical(fill, character(0)) &&- |
-
1028 | -10x | -
- (!is_point || identical(size, character(0)))- |
-
1029 | -- |
- ) {- |
-
1030 | -1x | -
- substitute(expr = aes(colour = colour_name), env = list(colour_name = as.name(colour)))- |
-
1031 | -- |
- } else if (- |
-
1032 | -9x | -
- identical(colour, character(0)) &&- |
-
1033 | -9x | -
- !identical(fill, character(0)) &&- |
-
1034 | -9x | -
- (!is_point || identical(size, character(0)))- |
-
1035 | -- |
- ) {- |
-
1036 | -2x | -
- substitute(expr = aes(fill = fill_name), env = list(fill_name = as.name(fill)))- |
-
1037 | -- |
- } else if (- |
-
1038 | -7x | -
- identical(colour, character(0)) &&- |
-
1039 | -7x | -
- identical(fill, character(0)) &&- |
-
1040 | -7x | -
- is_point &&- |
-
1041 | -7x | -
- !identical(size, character(0))- |
-
1042 | -- |
- ) {- |
-
1043 | -1x | -
- substitute(expr = aes(size = size_name), env = list(size_name = as.name(size)))- |
-
1044 | -- |
- } else if (- |
-
1045 | -6x | -
- !identical(colour, character(0)) &&- |
-
1046 | -6x | -
- identical(fill, character(0)) &&- |
-
1047 | -6x | -
- is_point &&- |
-
1048 | -6x | -
- !identical(size, character(0))- |
-
1049 | -- |
- ) {- |
-
1050 | -1x | -
- substitute(- |
-
1051 | -1x | -
- expr = aes(colour = colour_name, size = size_name),- |
-
1052 | -1x | -
- env = list(colour_name = as.name(colour), size_name = as.name(size))- |
-
1053 | -- |
- )- |
-
1054 | -- |
- } else if (- |
-
1055 | -5x | -
- identical(colour, character(0)) &&- |
-
1056 | -5x | -
- !identical(fill, character(0)) &&- |
-
1057 | -5x | -
- is_point &&- |
-
1058 | -5x | -
- !identical(size, character(0))- |
-
1059 | -- |
- ) {- |
-
1060 | -1x | -
- substitute(- |
-
1061 | -1x | -
- expr = aes(colour = colour_name, fill = fill_name, size = size_name),- |
-
1062 | -1x | -
- env = list(colour_name = as.name(fill), fill_name = as.name(fill), size_name = as.name(size))- |
-
1063 | -- |
- )- |
-
1064 | -- |
- } else {- |
-
1065 | -4x | -
- NULL- |
-
1066 | -- |
- }- |
-
1067 | -- |
- }- |
-
1 | -- |
- #' `teal` module: Response plot- |
-
2 | -- |
- #'- |
-
3 | -- |
- #' Generates a response plot for a given `response` and `x` variables.- |
-
4 | -- |
- #' This module allows users customize and add annotations to the plot depending- |
-
5 | -- |
- #' on the module's arguments.- |
-
6 | -- |
- #' It supports showing the counts grouped by other variable facets (by row / column),- |
-
7 | -- |
- #' swapping the coordinates, show count annotations and displaying the response plot- |
-
8 | -- |
- #' as frequency or density.- |
-
9 | -- |
- #'- |
-
10 | -- |
- #' @inheritParams teal::module- |
-
11 | -- |
- #' @inheritParams shared_params- |
-
12 | -- |
- #' @param response (`data_extract_spec` or `list` of multiple `data_extract_spec`)- |
-
13 | -- |
- #' Which variable to use as the response.- |
-
14 | -- |
- #' You can define one fixed column by setting `fixed = TRUE` inside the `select_spec`.- |
-
15 | -- |
- #'- |
-
16 | -- |
- #' The `data_extract_spec` must not allow multiple selection in this case.- |
-
17 | -- |
- #' @param x (`data_extract_spec` or `list` of multiple `data_extract_spec`)- |
-
18 | -- |
- #' Specifies which variable to use on the X-axis of the response plot.- |
-
19 | -- |
- #' Allow the user to select multiple columns from the `data` allowed in teal.- |
-
20 | -- |
- #'- |
-
21 | -- |
- #' The `data_extract_spec` must not allow multiple selection in this case.- |
-
22 | -- |
- #' @param row_facet (`data_extract_spec` or `list` of multiple `data_extract_spec`)- |
-
23 | -- |
- #' optional specification of the data variable(s) to use for faceting rows.- |
-
24 | -- |
- #' @param col_facet (`data_extract_spec` or `list` of multiple `data_extract_spec`)- |
-
25 | -- |
- #' optional specification of the data variable(s) to use for faceting columns.- |
-
26 | -- |
- #' @param coord_flip (`logical(1)`)- |
-
27 | -- |
- #' Indicates whether to flip coordinates between `x` and `response`.- |
-
28 | -- |
- #' The default value is `FALSE` and it will show the `x` variable on the x-axis- |
-
29 | -- |
- #' and the `response` variable on the y-axis.- |
-
30 | -- |
- #' @param count_labels (`logical(1)`)- |
-
31 | -- |
- #' Indicates whether to show count labels.- |
-
32 | -- |
- #' Defaults to `TRUE`.- |
-
33 | -- |
- #' @param freq (`logical(1)`)- |
-
34 | -- |
- #' Indicates whether to display frequency (`TRUE`) or density (`FALSE`).- |
-
35 | -- |
- #' Defaults to density (`FALSE`).- |
-
36 | -- |
- #'- |
-
37 | -- |
- #' @inherit shared_params return- |
-
38 | -- |
- #'- |
-
39 | -- |
- #' @note For more examples, please see the vignette "Using response plot" via- |
-
40 | -- |
- #' `vignette("using-response-plot", package = "teal.modules.general")`.- |
-
41 | -- |
- #'- |
-
42 | -- |
- #' @examples- |
-
43 | -- |
- #' # general data example- |
-
44 | -- |
- #' library(teal.widgets)- |
-
45 | -- |
- #'- |
-
46 | -- |
- #' data <- teal_data()- |
-
47 | -- |
- #' data <- within(data, {- |
-
48 | -- |
- #' require(nestcolor)- |
-
49 | -- |
- #' mtcars <- mtcars- |
-
50 | -- |
- #' for (v in c("cyl", "vs", "am", "gear")) {- |
-
51 | -- |
- #' mtcars[[v]] <- as.factor(mtcars[[v]])- |
-
52 | -- |
- #' }- |
-
53 | -- |
- #' })- |
-
54 | -- |
- #' datanames(data) <- "mtcars"- |
-
55 | -- |
- #'- |
-
56 | -- |
- #' app <- init(- |
-
57 | -- |
- #' data = data,- |
-
58 | -- |
- #' modules = modules(- |
-
59 | -- |
- #' tm_g_response(- |
-
60 | -- |
- #' label = "Response Plots",- |
-
61 | -- |
- #' response = data_extract_spec(- |
-
62 | -- |
- #' dataname = "mtcars",- |
-
63 | -- |
- #' select = select_spec(- |
-
64 | -- |
- #' label = "Select variable:",- |
-
65 | -- |
- #' choices = variable_choices(data[["mtcars"]], c("cyl", "gear")),- |
-
66 | -- |
- #' selected = "cyl",- |
-
67 | -- |
- #' multiple = FALSE,- |
-
68 | -- |
- #' fixed = FALSE- |
-
69 | -- |
- #' )- |
-
70 | -- |
- #' ),- |
-
71 | -- |
- #' x = data_extract_spec(- |
-
72 | -- |
- #' dataname = "mtcars",- |
-
73 | -- |
- #' select = select_spec(- |
-
74 | -- |
- #' label = "Select variable:",- |
-
75 | -- |
- #' choices = variable_choices(data[["mtcars"]], c("vs", "am")),- |
-
76 | -- |
- #' selected = "vs",- |
-
77 | -- |
- #' multiple = FALSE,- |
-
78 | -- |
- #' fixed = FALSE- |
-
79 | -- |
- #' )- |
-
80 | -- |
- #' ),- |
-
81 | -- |
- #' ggplot2_args = ggplot2_args(- |
-
82 | -- |
- #' labs = list(subtitle = "Plot generated by Response Module")- |
-
83 | -- |
- #' )- |
-
84 | -- |
- #' )- |
-
85 | -- |
- #' )- |
-
86 | -- |
- #' )- |
-
87 | -- |
- #' if (interactive()) {- |
-
88 | -- |
- #' shinyApp(app$ui, app$server)- |
-
89 | -- |
- #' }- |
-
90 | -- |
- #'- |
-
91 | -- |
- #' # CDISC data example- |
-
92 | -- |
- #' library(teal.widgets)- |
-
93 | -- |
- #'- |
-
94 | -- |
- #' data <- teal_data()- |
-
95 | -- |
- #' data <- within(data, {- |
-
96 | -- |
- #' require(nestcolor)- |
-
97 | -- |
- #' ADSL <- rADSL- |
-
98 | -- |
- #' })- |
-
99 | -- |
- #' datanames(data) <- c("ADSL")- |
-
100 | -- |
- #' join_keys(data) <- default_cdisc_join_keys[datanames(data)]- |
-
101 | -- |
- #'- |
-
102 | -- |
- #' app <- init(- |
-
103 | -- |
- #' data = data,- |
-
104 | -- |
- #' modules = modules(- |
-
105 | -- |
- #' tm_g_response(- |
-
106 | -- |
- #' label = "Response Plots",- |
-
107 | -- |
- #' response = data_extract_spec(- |
-
108 | -- |
- #' dataname = "ADSL",- |
-
109 | -- |
- #' select = select_spec(- |
-
110 | -- |
- #' label = "Select variable:",- |
-
111 | -- |
- #' choices = variable_choices(data[["ADSL"]], c("BMRKR2", "COUNTRY")),- |
-
112 | -- |
- #' selected = "BMRKR2",- |
-
113 | -- |
- #' multiple = FALSE,- |
-
114 | -- |
- #' fixed = FALSE- |
-
115 | -- |
- #' )- |
-
116 | -- |
- #' ),- |
-
117 | -- |
- #' x = data_extract_spec(- |
-
118 | -- |
- #' dataname = "ADSL",- |
-
119 | -- |
- #' select = select_spec(- |
-
120 | -- |
- #' label = "Select variable:",- |
-
121 | -- |
- #' choices = variable_choices(data[["ADSL"]], c("SEX", "RACE")),- |
-
122 | -- |
- #' selected = "RACE",- |
-
123 | -- |
- #' multiple = FALSE,- |
-
124 | -- |
- #' fixed = FALSE- |
-
125 | -- |
- #' )- |
-
126 | -- |
- #' ),- |
-
127 | -- |
- #' ggplot2_args = ggplot2_args(- |
-
128 | -- |
- #' labs = list(subtitle = "Plot generated by Response Module")- |
-
129 | -- |
- #' )- |
-
130 | -- |
- #' )- |
-
131 | -- |
- #' )- |
-
132 | -- |
- #' )- |
-
133 | -- |
- #' if (interactive()) {- |
-
134 | -- |
- #' shinyApp(app$ui, app$server)- |
-
135 | -- |
- #' }- |
-
136 | -- |
- #'- |
-
137 | -- |
- #' @export- |
-
138 | -- |
- #'- |
-
139 | -- |
- tm_g_response <- function(label = "Response Plot",- |
-
140 | -- |
- response,- |
-
141 | -- |
- x,- |
-
142 | -- |
- row_facet = NULL,- |
-
143 | -- |
- col_facet = NULL,- |
-
144 | -- |
- coord_flip = FALSE,- |
-
145 | -- |
- count_labels = TRUE,- |
-
146 | -- |
- rotate_xaxis_labels = FALSE,- |
-
147 | -- |
- freq = FALSE,- |
-
148 | -- |
- plot_height = c(600, 400, 5000),- |
-
149 | -- |
- plot_width = NULL,- |
-
150 | -- |
- ggtheme = c("gray", "bw", "linedraw", "light", "dark", "minimal", "classic", "void"),- |
-
151 | -- |
- ggplot2_args = teal.widgets::ggplot2_args(),- |
-
152 | -- |
- pre_output = NULL,- |
-
153 | -- |
- post_output = NULL) {- |
-
154 | -! | -
- logger::log_info("Initializing tm_g_response")- |
-
155 | -- | - - | -
156 | -- |
- # Normalize the parameters- |
-
157 | -! | -
- if (inherits(response, "data_extract_spec")) response <- list(response)- |
-
158 | -! | -
- if (inherits(x, "data_extract_spec")) x <- list(x)- |
-
159 | -! | -
- if (inherits(row_facet, "data_extract_spec")) row_facet <- list(row_facet)- |
-
160 | -! | -
- if (inherits(col_facet, "data_extract_spec")) col_facet <- list(col_facet)- |
-
161 | -- | - - | -
162 | -- |
- # Start of assertions- |
-
163 | -! | -
- checkmate::assert_string(label)- |
-
164 | -- | - - | -
165 | -! | -
- checkmate::assert_list(response, types = "data_extract_spec")- |
-
166 | -! | -
- if (!all(vapply(response, function(x) !("" %in% x$select$choices), logical(1)))) {- |
-
167 | -! | -
- stop("'response' should not allow empty values")- |
-
168 | -- |
- }- |
-
169 | -! | -
- assert_single_selection(response)- |
-
170 | -- | - - | -
171 | -! | -
- checkmate::assert_list(x, types = "data_extract_spec")- |
-
172 | -! | -
- if (!all(vapply(x, function(x) !("" %in% x$select$choices), logical(1)))) {- |
-
173 | -! | -
- stop("'x' should not allow empty values")- |
-
174 | -- |
- }- |
-
175 | -! | -
- assert_single_selection(x)- |
-
176 | -- | - - | -
177 | -! | -
- checkmate::assert_list(row_facet, types = "data_extract_spec", null.ok = TRUE)- |
-
178 | -! | -
- checkmate::assert_list(col_facet, types = "data_extract_spec", null.ok = TRUE)- |
-
179 | -! | -
- checkmate::assert_flag(coord_flip)- |
-
180 | -! | -
- checkmate::assert_flag(count_labels)- |
-
181 | -! | -
- checkmate::assert_flag(rotate_xaxis_labels)- |
-
182 | -! | -
- checkmate::assert_flag(freq)- |
-
183 | -- | - - | -
184 | -! | -
- checkmate::assert_numeric(plot_height, len = 3, any.missing = FALSE, finite = TRUE)- |
-
185 | -! | -
- checkmate::assert_numeric(plot_height[1], lower = plot_height[2], upper = plot_height[3], .var.name = "plot_height")- |
-
186 | -! | -
- checkmate::assert_numeric(plot_width, len = 3, any.missing = FALSE, null.ok = TRUE, finite = TRUE)- |
-
187 | -! | -
- checkmate::assert_numeric(- |
-
188 | -! | -
- plot_width[1],- |
-
189 | -! | -
- lower = plot_width[2], upper = plot_width[3], null.ok = TRUE, .var.name = "plot_width"- |
-
190 | -- |
- )- |
-
191 | -- | - - | -
192 | -! | -
- ggtheme <- match.arg(ggtheme)- |
-
193 | -! | -
- checkmate::assert_class(ggplot2_args, "ggplot2_args")- |
-
194 | -- | - - | -
195 | -! | -
- checkmate::assert_multi_class(pre_output, c("shiny.tag", "shiny.tag.list", "html"), null.ok = TRUE)- |
-
196 | -! | -
- checkmate::assert_multi_class(post_output, c("shiny.tag", "shiny.tag.list", "html"), null.ok = TRUE)- |
-
197 | -- |
- # End of assertions- |
-
198 | -- | - - | -
199 | -- |
- # Make UI args- |
-
200 | -! | -
- args <- as.list(environment())- |
-
201 | -- | - - | -
202 | -! | -
- data_extract_list <- list(- |
-
203 | -! | -
- response = response,- |
-
204 | -! | -
- x = x,- |
-
205 | -! | -
- row_facet = row_facet,- |
-
206 | -! | -
- col_facet = col_facet- |
-
207 | -- |
- )- |
-
208 | -- | - - | -
209 | -! | -
- module(- |
-
210 | -! | -
- label = label,- |
-
211 | -! | -
- server = srv_g_response,- |
-
212 | -! | -
- ui = ui_g_response,- |
-
213 | -! | -
- ui_args = args,- |
-
214 | -! | -
- server_args = c(- |
-
215 | -! | -
- data_extract_list,- |
-
216 | -! | -
- list(plot_height = plot_height, plot_width = plot_width, ggplot2_args = ggplot2_args)- |
-
217 | -- |
- ),- |
-
218 | -! | -
- datanames = teal.transform::get_extract_datanames(data_extract_list)- |
-
219 | -- |
- )- |
-
220 | -- |
- }- |
-
221 | -- | - - | -
222 | -- |
- # UI function for the response module- |
-
223 | -- |
- ui_g_response <- function(id, ...) {- |
-
224 | -! | -
- ns <- NS(id)- |
-
225 | -! | -
- args <- list(...)- |
-
226 | -! | -
- is_single_dataset_value <- teal.transform::is_single_dataset(args$response, args$x, args$row_facet, args$col_facet)- |
-
227 | -- | - - | -
228 | -! | -
- teal.widgets::standard_layout(- |
-
229 | -! | -
- output = teal.widgets::white_small_well(- |
-
230 | -! | -
- teal.widgets::plot_with_settings_ui(id = ns("myplot"))- |
-
231 | -- |
- ),- |
-
232 | -! | -
- encoding = div(- |
-
233 | -- |
- ### Reporter- |
-
234 | -! | -
- teal.reporter::simple_reporter_ui(ns("simple_reporter")),- |
-
235 | -- |
- ###- |
-
236 | -! | -
- tags$label("Encodings", class = "text-primary"),- |
-
237 | -! | -
- teal.transform::datanames_input(args[c("response", "x", "row_facet", "col_facet")]),- |
-
238 | -! | -
- teal.transform::data_extract_ui(- |
-
239 | -! | -
- id = ns("response"),- |
-
240 | -! | -
- label = "Response variable",- |
-
241 | -! | -
- data_extract_spec = args$response,- |
-
242 | -! | -
- is_single_dataset = is_single_dataset_value- |
-
243 | -- |
- ),- |
-
244 | -! | -
- teal.transform::data_extract_ui(- |
-
245 | -! | -
- id = ns("x"),- |
-
246 | -! | -
- label = "X variable",- |
-
247 | -! | -
- data_extract_spec = args$x,- |
-
248 | -! | -
- is_single_dataset = is_single_dataset_value- |
-
249 | -- |
- ),- |
-
250 | -! | -
- if (!is.null(args$row_facet)) {- |
-
251 | -! | -
- teal.transform::data_extract_ui(- |
-
252 | -! | -
- id = ns("row_facet"),- |
-
253 | -! | -
- label = "Row facetting",- |
-
254 | -! | -
- data_extract_spec = args$row_facet,- |
-
255 | -! | -
- is_single_dataset = is_single_dataset_value- |
-
256 | -- |
- )- |
-
257 | -- |
- },- |
-
258 | -! | -
- if (!is.null(args$col_facet)) {- |
-
259 | -! | -
- teal.transform::data_extract_ui(- |
-
260 | -! | -
- id = ns("col_facet"),- |
-
261 | -! | -
- label = "Column facetting",- |
-
262 | -! | -
- data_extract_spec = args$col_facet,- |
-
263 | -! | -
- is_single_dataset = is_single_dataset_value- |
-
264 | -- |
- )- |
-
265 | -- |
- },- |
-
266 | -! | -
- shinyWidgets::radioGroupButtons(- |
-
267 | -! | -
- inputId = ns("freq"),- |
-
268 | -! | -
- label = NULL,- |
-
269 | -! | -
- choices = c("frequency", "density"),- |
-
270 | -! | -
- selected = ifelse(args$freq, "frequency", "density"),- |
-
271 | -! | -
- justified = TRUE- |
-
272 | -- |
- ),- |
-
273 | -! | -
- teal.widgets::panel_group(- |
-
274 | -! | -
- teal.widgets::panel_item(- |
-
275 | -! | -
- title = "Plot settings",- |
-
276 | -! | -
- checkboxInput(ns("count_labels"), "Add count labels", value = args$count_labels),- |
-
277 | -! | -
- checkboxInput(ns("coord_flip"), "Swap axes", value = args$coord_flip),- |
-
278 | -! | -
- checkboxInput(ns("rotate_xaxis_labels"), "Rotate X axis labels", value = args$rotate_xaxis_labels),- |
-
279 | -! | -
- selectInput(- |
-
280 | -! | -
- inputId = ns("ggtheme"),- |
-
281 | -! | -
- label = "Theme (by ggplot):",- |
-
282 | -! | -
- choices = ggplot_themes,- |
-
283 | -! | -
- selected = args$ggtheme,- |
-
284 | -! | -
- multiple = FALSE- |
-
285 | -- |
- )- |
-
286 | -- |
- )- |
-
287 | -- |
- )- |
-
288 | -- |
- ),- |
-
289 | -! | -
- forms = tagList(- |
-
290 | -! | -
- teal.widgets::verbatim_popup_ui(ns("warning"), button_label = "Show Warnings"),- |
-
291 | -! | -
- teal.widgets::verbatim_popup_ui(ns("rcode"), "Show R code")- |
-
292 | -- |
- ),- |
-
293 | -! | -
- pre_output = args$pre_output,- |
-
294 | -! | -
- post_output = args$post_output- |
-
295 | -- |
- )- |
-
296 | -- |
- }- |
-
297 | -- | - - | -
298 | -- |
- # Server function for the response module- |
-
299 | -- |
- srv_g_response <- function(id,- |
-
300 | -- |
- data,- |
-
301 | -- |
- reporter,- |
-
302 | -- |
- filter_panel_api,- |
-
303 | -- |
- response,- |
-
304 | -- |
- x,- |
-
305 | -- |
- row_facet,- |
-
306 | -- |
- col_facet,- |
-
307 | -- |
- plot_height,- |
-
308 | -- |
- plot_width,- |
-
309 | -- |
- ggplot2_args) {- |
-
310 | -! | -
- with_reporter <- !missing(reporter) && inherits(reporter, "Reporter")- |
-
311 | -! | -
- with_filter <- !missing(filter_panel_api) && inherits(filter_panel_api, "FilterPanelAPI")- |
-
312 | -! | -
- checkmate::assert_class(data, "reactive")- |
-
313 | -! | -
- checkmate::assert_class(isolate(data()), "teal_data")- |
-
314 | -! | -
- moduleServer(id, function(input, output, session) {- |
-
315 | -! | -
- data_extract <- list(response = response, x = x, row_facet = row_facet, col_facet = col_facet)- |
-
316 | -- | - - | -
317 | -! | -
- rule_diff <- function(other) {- |
-
318 | -! | -
- function(value) {- |
-
319 | -! | -
- if (other %in% names(selector_list())) {- |
-
320 | -! | -
- othervalue <- selector_list()[[other]]()[["select"]]- |
-
321 | -! | -
- if (!is.null(othervalue)) {- |
-
322 | -! | -
- if (identical(value, othervalue)) {- |
-
323 | -! | -
- "Row and column facetting variables must be different."- |
-
324 | -- |
- }- |
-
325 | -- |
- }- |
-
326 | -- |
- }- |
-
327 | -- |
- }- |
-
328 | -- |
- }- |
-
329 | -- | - - | -
330 | -! | -
- selector_list <- teal.transform::data_extract_multiple_srv(- |
-
331 | -! | -
- data_extract = data_extract,- |
-
332 | -! | -
- datasets = data,- |
-
333 | -! | -
- select_validation_rule = list(- |
-
334 | -! | -
- response = shinyvalidate::sv_required("Please define a column for the response variable"),- |
-
335 | -! | -
- x = shinyvalidate::sv_required("Please define a column for X variable"),- |
-
336 | -! | -
- row_facet = shinyvalidate::compose_rules(- |
-
337 | -! | -
- shinyvalidate::sv_optional(),- |
-
338 | -! | -
- ~ if (length(.) > 1) "There must be 1 or no row facetting variable.",- |
-
339 | -! | -
- rule_diff("col_facet")- |
-
340 | -- |
- ),- |
-
341 | -! | -
- col_facet = shinyvalidate::compose_rules(- |
-
342 | -! | -
- shinyvalidate::sv_optional(),- |
-
343 | -! | -
- ~ if (length(.) > 1) "There must be 1 or no column facetting variable.",- |
-
344 | -! | -
- rule_diff("row_facet")- |
-
345 | -- |
- )- |
-
346 | -- |
- )- |
-
347 | -- |
- )- |
-
348 | -- | - - | -
349 | -! | -
- iv_r <- reactive({- |
-
350 | -! | -
- iv <- shinyvalidate::InputValidator$new()- |
-
351 | -! | -
- iv$add_rule("ggtheme", shinyvalidate::sv_required("Please select a theme"))- |
-
352 | -! | -
- teal.transform::compose_and_enable_validators(iv, selector_list)- |
-
353 | -- |
- })- |
-
354 | -- | - - | -
355 | -! | -
- anl_merged_input <- teal.transform::merge_expression_srv(- |
-
356 | -! | -
- selector_list = selector_list,- |
-
357 | -! | -
- datasets = data- |
-
358 | -- |
- )- |
-
359 | -- | - - | -
360 | -! | -
- anl_merged_q <- reactive({- |
-
361 | -! | -
- req(anl_merged_input())- |
-
362 | -! | -
- data() %>%- |
-
363 | -! | -
- teal.code::eval_code(as.expression(anl_merged_input()$expr))- |
-
364 | -- |
- })- |
-
365 | -- | - - | -
366 | -! | -
- merged <- list(- |
-
367 | -! | -
- anl_input_r = anl_merged_input,- |
-
368 | -! | -
- anl_q_r = anl_merged_q- |
-
369 | -- |
- )- |
-
370 | -- | - - | -
371 | -! | -
- output_q <- reactive({- |
-
372 | -! | -
- teal::validate_inputs(iv_r())- |
-
373 | -- | - - | -
374 | -! | -
- qenv <- merged$anl_q_r()- |
-
375 | -! | -
- ANL <- qenv[["ANL"]]- |
-
376 | -! | -
- resp_var <- as.vector(merged$anl_input_r()$columns_source$response)- |
-
377 | -! | -
- x <- as.vector(merged$anl_input_r()$columns_source$x)- |
-
378 | -- | - - | -
379 | -! | -
- validate(need(is.factor(ANL[[resp_var]]), "Please select a factor variable as the response."))- |
-
380 | -! | -
- validate(need(is.factor(ANL[[x]]), "Please select a factor variable as the X-Variable."))- |
-
381 | -! | -
- teal::validate_has_data(ANL, 10)- |
-
382 | -! | -
- teal::validate_has_data(ANL[, c(resp_var, x)], 10, complete = TRUE, allow_inf = FALSE)- |
-
383 | -- | - - | -
384 | -! | -
- row_facet_name <- if (length(merged$anl_input_r()$columns_source$row_facet) == 0) {- |
-
385 | -! | -
- character(0)- |
-
386 | -- |
- } else {- |
-
387 | -! | -
- as.vector(merged$anl_input_r()$columns_source$row_facet)- |
-
388 | -- |
- }- |
-
389 | -! | -
- col_facet_name <- if (length(merged$anl_input_r()$columns_source$col_facet) == 0) {- |
-
390 | -! | -
- character(0)- |
-
391 | -- |
- } else {- |
-
392 | -! | -
- as.vector(merged$anl_input_r()$columns_source$col_facet)- |
-
393 | -- |
- }- |
-
394 | -- | - - | -
395 | -! | -
- freq <- input$freq == "frequency"- |
-
396 | -! | -
- swap_axes <- input$coord_flip- |
-
397 | -! | -
- counts <- input$count_labels- |
-
398 | -! | -
- rotate_xaxis_labels <- input$rotate_xaxis_labels- |
-
399 | -! | -
- ggtheme <- input$ggtheme- |
-
400 | -- | - - | -
401 | -! | -
- arg_position <- if (freq) "stack" else "fill"- |
-
402 | -- | - - | -
403 | -! | -
- rowf <- if (length(row_facet_name) != 0) as.name(row_facet_name)- |
-
404 | -! | -
- colf <- if (length(col_facet_name) != 0) as.name(col_facet_name)- |
-
405 | -! | -
- resp_cl <- as.name(resp_var)- |
-
406 | -! | -
- x_cl <- as.name(x)- |
-
407 | -- | - - | -
408 | -! | -
- if (swap_axes) {- |
-
409 | -! | -
- qenv <- teal.code::eval_code(- |
-
410 | -! | -
- qenv,- |
-
411 | -! | -
- substitute(- |
-
412 | -! | -
- expr = ANL[[x]] <- with(ANL, forcats::fct_rev(x_cl)),- |
-
413 | -! | -
- env = list(x = x, x_cl = x_cl)- |
-
414 | -- |
- )- |
-
415 | -- |
- )- |
-
416 | -- |
- }- |
-
417 | -- | - - | -
418 | -! | -
- qenv <- teal.code::eval_code(- |
-
419 | -! | -
- qenv,- |
-
420 | -! | -
- substitute(- |
-
421 | -! | -
- expr = ANL[[resp_var]] <- factor(ANL[[resp_var]]),- |
-
422 | -! | -
- env = list(resp_var = resp_var)- |
-
423 | -- |
- )- |
-
424 | -- |
- ) %>%- |
-
425 | -- |
- # rowf and colf will be a NULL if not set by a user- |
-
426 | -! | -
- teal.code::eval_code(- |
-
427 | -! | -
- substitute(- |
-
428 | -! | -
- expr = ANL2 <- ANL %>%- |
-
429 | -! | -
- dplyr::group_by_at(dplyr::vars(x_cl, resp_cl, rowf, colf)) %>%- |
-
430 | -! | -
- dplyr::summarise(ns = dplyr::n()) %>%- |
-
431 | -! | -
- dplyr::group_by_at(dplyr::vars(x_cl, rowf, colf)) %>%- |
-
432 | -! | -
- dplyr::mutate(sums = sum(ns), percent = round(ns / sums * 100, 1)),- |
-
433 | -! | -
- env = list(x_cl = x_cl, resp_cl = resp_cl, rowf = rowf, colf = colf)- |
-
434 | -- |
- )- |
-
435 | -- |
- ) %>%- |
-
436 | -! | -
- teal.code::eval_code(- |
-
437 | -! | -
- substitute(- |
-
438 | -! | -
- expr = ANL3 <- ANL %>%- |
-
439 | -! | -
- dplyr::group_by_at(dplyr::vars(x_cl, rowf, colf)) %>%- |
-
440 | -! | -
- dplyr::summarise(ns = dplyr::n()),- |
-
441 | -! | -
- env = list(x_cl = x_cl, rowf = rowf, colf = colf)- |
-
442 | -- |
- )- |
-
443 | -- |
- )- |
-
444 | -- | - - | -
445 | -! | -
- plot_call <- substitute(- |
-
446 | -! | -
- expr = ggplot(ANL2, aes(x = x_cl, y = ns)) +- |
-
447 | -! | -
- geom_bar(aes(fill = resp_cl), stat = "identity", position = arg_position),- |
-
448 | -! | -
- env = list(- |
-
449 | -! | -
- x_cl = x_cl,- |
-
450 | -! | -
- resp_cl = resp_cl,- |
-
451 | -! | -
- arg_position = arg_position- |
-
452 | -- |
- )- |
-
453 | -- |
- )- |
-
454 | -- | - - | -
455 | -! | -
- if (!freq) plot_call <- substitute(plot_call + expand_limits(y = c(0, 1.1)), env = list(plot_call = plot_call))- |
-
456 | -- | - - | -
457 | -! | -
- if (counts) {- |
-
458 | -! | -
- plot_call <- substitute(- |
-
459 | -! | -
- expr = plot_call +- |
-
460 | -! | -
- geom_text(- |
-
461 | -! | -
- data = ANL2,- |
-
462 | -! | -
- aes(label = ns, x = x_cl, y = ns, group = resp_cl),- |
-
463 | -! | -
- col = "white",- |
-
464 | -! | -
- vjust = "middle",- |
-
465 | -! | -
- hjust = "middle",- |
-
466 | -! | -
- position = position_anl2_value- |
-
467 | -- |
- ) +- |
-
468 | -! | -
- geom_text(- |
-
469 | -! | -
- data = ANL3, aes(label = ns, x = x_cl, y = anl3_y),- |
-
470 | -! | -
- hjust = hjust_value,- |
-
471 | -! | -
- vjust = vjust_value,- |
-
472 | -! | -
- position = position_anl3_value- |
-
473 | -- |
- ),- |
-
474 | -! | -
- env = list(- |
-
475 | -! | -
- plot_call = plot_call,- |
-
476 | -! | -
- x_cl = x_cl,- |
-
477 | -! | -
- resp_cl = resp_cl,- |
-
478 | -! | -
- hjust_value = if (swap_axes) "left" else "middle",- |
-
479 | -! | -
- vjust_value = if (swap_axes) "middle" else -1,- |
-
480 | -! | -
- position_anl2_value = if (!freq) quote(position_fill(0.5)) else quote(position_stack(0.5)),- |
-
481 | -! | -
- anl3_y = if (!freq) 1.1 else as.name("ns"),- |
-
482 | -! | -
- position_anl3_value = if (!freq) "fill" else "stack"- |
-
483 | -- |
- )- |
-
484 | -- |
- )- |
-
485 | -- |
- }- |
-
486 | -- | - - | -
487 | -! | -
- if (swap_axes) {- |
-
488 | -! | -
- plot_call <- substitute(plot_call + coord_flip(), env = list(plot_call = plot_call))- |
-
489 | -- |
- }- |
-
490 | -- | - - | -
491 | -! | -
- facet_cl <- facet_ggplot_call(row_facet_name, col_facet_name)- |
-
492 | -- | - - | -
493 | -! | -
- if (!is.null(facet_cl)) {- |
-
494 | -! | -
- plot_call <- substitute(expr = plot_call + facet_cl, env = list(plot_call = plot_call, facet_cl = facet_cl))- |
-
495 | -- |
- }- |
-
496 | -- | - - | -
497 | -! | -
- dev_ggplot2_args <- teal.widgets::ggplot2_args(- |
-
498 | -! | -
- labs = list(- |
-
499 | -! | -
- x = varname_w_label(x, ANL),- |
-
500 | -! | -
- y = varname_w_label(resp_var, ANL, prefix = "Proportion of "),- |
-
501 | -! | -
- fill = varname_w_label(resp_var, ANL)- |
-
502 | -- |
- ),- |
-
503 | -! | -
- theme = list(legend.position = "bottom")- |
-
504 | -- |
- )- |
-
505 | -- | - - | -
506 | -! | -
- if (rotate_xaxis_labels) {- |
-
507 | -! | -
- dev_ggplot2_args$theme[["axis.text.x"]] <- quote(element_text(angle = 45, hjust = 1))- |
-
508 | -- |
- }- |
-
509 | -- | - - | -
510 | -! | -
- all_ggplot2_args <- teal.widgets::resolve_ggplot2_args(- |
-
511 | -! | -
- user_plot = ggplot2_args,- |
-
512 | -! | -
- module_plot = dev_ggplot2_args- |
-
513 | -- |
- )- |
-
514 | -- | - - | -
515 | -! | -
- parsed_ggplot2_args <- teal.widgets::parse_ggplot2_args(- |
-
516 | -! | -
- all_ggplot2_args,- |
-
517 | -! | -
- ggtheme = ggtheme- |
-
518 | -- |
- )- |
-
519 | -- | - - | -
520 | -! | -
- plot_call <- substitute(expr = {- |
-
521 | -! | -
- p <- plot_call + labs + ggthemes + themes- |
-
522 | -! | -
- print(p)- |
-
523 | -! | -
- }, env = list(- |
-
524 | -! | -
- plot_call = plot_call,- |
-
525 | -! | -
- labs = parsed_ggplot2_args$labs,- |
-
526 | -! | -
- themes = parsed_ggplot2_args$theme,- |
-
527 | -! | -
- ggthemes = parsed_ggplot2_args$ggtheme- |
-
528 | -- |
- ))- |
-
529 | -- | - - | -
530 | -! | -
- teal.code::eval_code(qenv, plot_call)- |
-
531 | -- |
- })- |
-
532 | -- | - - | -
533 | -! | -
- plot_r <- reactive(output_q()[["p"]])- |
-
534 | -- | - - | -
535 | -- |
- # Insert the plot into a plot_with_settings module from teal.widgets- |
-
536 | -! | -
- pws <- teal.widgets::plot_with_settings_srv(- |
-
537 | -! | -
- id = "myplot",- |
-
538 | -! | -
- plot_r = plot_r,- |
-
539 | -! | -
- height = plot_height,- |
-
540 | -! | -
- width = plot_width- |
-
541 | -- |
- )- |
-
542 | -- | - - | -
543 | -! | -
- teal.widgets::verbatim_popup_srv(- |
-
544 | -! | -
- id = "warning",- |
-
545 | -! | -
- verbatim_content = reactive(teal.code::get_warnings(output_q())),- |
-
546 | -! | -
- title = "Warning",- |
-
547 | -! | -
- disabled = reactive(is.null(teal.code::get_warnings(output_q())))- |
-
548 | -- |
- )- |
-
549 | -- | - - | -
550 | -! | -
- teal.widgets::verbatim_popup_srv(- |
-
551 | -! | -
- id = "rcode",- |
-
552 | -! | -
- verbatim_content = reactive(teal.code::get_code(output_q())),- |
-
553 | -! | -
- title = "Show R Code for Response"- |
-
554 | -- |
- )- |
-
555 | -- | - - | -
556 | -- |
- ### REPORTER- |
-
557 | -! | -
- if (with_reporter) {- |
-
558 | -! | -
- card_fun <- function(comment, label) {- |
-
559 | -! | -
- card <- teal::report_card_template(- |
-
560 | -! | -
- title = "Response Plot",- |
-
561 | -! | -
- label = label,- |
-
562 | -! | -
- with_filter = with_filter,- |
-
563 | -! | -
- filter_panel_api = filter_panel_api- |
-
564 | -- |
- )- |
-
565 | -! | -
- card$append_text("Plot", "header3")- |
-
566 | -! | -
- card$append_plot(plot_r(), dim = pws$dim())- |
-
567 | -! | -
- if (!comment == "") {- |
-
568 | -! | -
- card$append_text("Comment", "header3")- |
-
569 | -! | -
- card$append_text(comment)- |
-
570 | -- |
- }- |
-
571 | -! | -
- card$append_src(teal.code::get_code(output_q()))- |
-
572 | -! | -
- card- |
-
573 | -- |
- }- |
-
574 | -! | -
- teal.reporter::simple_reporter_srv("simple_reporter", reporter = reporter, card_fun = card_fun)- |
-
575 | -- |
- }- |
-
576 | -- |
- ###- |
-
577 | -- |
- })- |
-
578 | -- |
- }- |
-
1 | -- |
- #' `teal` module: Principal component analysis- |
-
2 | -- |
- #'- |
-
3 | -- |
- #' Module conducts principal component analysis (PCA) on a given dataset and offers different- |
-
4 | -- |
- #' ways of visualizing the outcomes, including elbow plot, circle plot, biplot, and eigenvector plot.- |
-
5 | -- |
- #' Additionally, it enables dynamic customization of plot aesthetics, such as opacity, size, and- |
-
6 | -- |
- #' font size, through UI inputs.- |
-
7 | -- |
- #'- |
-
8 | -- |
- #' @inheritParams teal::module- |
-
9 | -- |
- #' @inheritParams shared_params- |
-
10 | -- |
- #' @param dat (`data_extract_spec` or `list` of multiple `data_extract_spec`)- |
-
11 | -- |
- #' specifying columns used to compute PCA.- |
-
12 | -- |
- #' @param font_size (`numeric`) optional, specifies font size.- |
-
13 | -- |
- #' It controls the font size for plot titles, axis labels, and legends.- |
-
14 | -- |
- #' - If vector of `length == 1` then the font sizes will have a fixed size.- |
-
15 | -- |
- #' - while vector of `value`, `min`, and `max` allows dynamic adjustment.- |
-
16 | -- |
- #' @templateVar ggnames "Elbow plot", "Circle plot", "Biplot", "Eigenvector plot"- |
-
17 | -- |
- #' @template ggplot2_args_multi- |
-
18 | -- |
- #'- |
-
19 | -- |
- #' @inherit shared_params return- |
-
20 | -- |
- #'- |
-
21 | -- |
- #' @examples- |
-
22 | -- |
- #' library(teal.widgets)- |
-
23 | -- |
- #'- |
-
24 | -- |
- #' # general data example- |
-
25 | -- |
- #' data <- teal_data()- |
-
26 | -- |
- #' data <- within(data, {- |
-
27 | -- |
- #' require(nestcolor)- |
-
28 | -- |
- #' USArrests <- USArrests- |
-
29 | -- |
- #' })- |
-
30 | -- |
- #'- |
-
31 | -- |
- #' datanames(data) <- "USArrests"- |
-
32 | -- |
- #'- |
-
33 | -- |
- #' app <- init(- |
-
34 | -- |
- #' data = data,- |
-
35 | -- |
- #' modules = modules(- |
-
36 | -- |
- #' tm_a_pca(- |
-
37 | -- |
- #' "PCA",- |
-
38 | -- |
- #' dat = data_extract_spec(- |
-
39 | -- |
- #' dataname = "USArrests",- |
-
40 | -- |
- #' select = select_spec(- |
-
41 | -- |
- #' choices = variable_choices(- |
-
42 | -- |
- #' data = data[["USArrests"]], c("Murder", "Assault", "UrbanPop", "Rape")- |
-
43 | -- |
- #' ),- |
-
44 | -- |
- #' selected = c("Murder", "Assault"),- |
-
45 | -- |
- #' multiple = TRUE- |
-
46 | -- |
- #' ),- |
-
47 | -- |
- #' filter = NULL- |
-
48 | -- |
- #' ),- |
-
49 | -- |
- #' ggplot2_args = ggplot2_args(- |
-
50 | -- |
- #' labs = list(subtitle = "Plot generated by PCA Module")- |
-
51 | -- |
- #' )- |
-
52 | -- |
- #' )- |
-
53 | -- |
- #' )- |
-
54 | -- |
- #' )- |
-
55 | -- |
- #' if (interactive()) {- |
-
56 | -- |
- #' shinyApp(app$ui, app$server)- |
-
57 | -- |
- #' }- |
-
58 | -- |
- #'- |
-
59 | -- |
- #' # CDISC data example- |
-
60 | -- |
- #' data <- teal_data()- |
-
61 | -- |
- #' data <- within(data, {- |
-
62 | -- |
- #' require(nestcolor)- |
-
63 | -- |
- #' ADSL <- rADSL- |
-
64 | -- |
- #' })- |
-
65 | -- |
- #' datanames(data) <- "ADSL"- |
-
66 | -- |
- #' join_keys(data) <- default_cdisc_join_keys[datanames(data)]- |
-
67 | -- |
- #'- |
-
68 | -- |
- #' app <- init(- |
-
69 | -- |
- #' data = data,- |
-
70 | -- |
- #' modules = modules(- |
-
71 | -- |
- #' tm_a_pca(- |
-
72 | -- |
- #' "PCA",- |
-
73 | -- |
- #' dat = data_extract_spec(- |
-
74 | -- |
- #' dataname = "ADSL",- |
-
75 | -- |
- #' select = select_spec(- |
-
76 | -- |
- #' choices = variable_choices(- |
-
77 | -- |
- #' data = data[["ADSL"]], c("BMRKR1", "AGE", "EOSDY")- |
-
78 | -- |
- #' ),- |
-
79 | -- |
- #' selected = c("BMRKR1", "AGE"),- |
-
80 | -- |
- #' multiple = TRUE- |
-
81 | -- |
- #' ),- |
-
82 | -- |
- #' filter = NULL- |
-
83 | -- |
- #' ),- |
-
84 | -- |
- #' ggplot2_args = ggplot2_args(- |
-
85 | -- |
- #' labs = list(subtitle = "Plot generated by PCA Module")- |
-
86 | -- |
- #' )- |
-
87 | -- |
- #' )- |
-
88 | -- |
- #' )- |
-
89 | -- |
- #' )- |
-
90 | -- |
- #' if (interactive()) {- |
-
91 | -- |
- #' shinyApp(app$ui, app$server)- |
-
92 | -- |
- #' }- |
-
93 | -- |
- #'- |
-
94 | -- |
- #' @export- |
-
95 | -- |
- #'- |
-
96 | -- |
- tm_a_pca <- function(label = "Principal Component Analysis",- |
-
97 | -- |
- dat,- |
-
98 | -- |
- plot_height = c(600, 200, 2000),- |
-
99 | -- |
- plot_width = NULL,- |
-
100 | -- |
- ggtheme = c("gray", "bw", "linedraw", "light", "dark", "minimal", "classic", "void"),- |
-
101 | -- |
- ggplot2_args = teal.widgets::ggplot2_args(),- |
-
102 | -- |
- rotate_xaxis_labels = FALSE,- |
-
103 | -- |
- font_size = c(12, 8, 20),- |
-
104 | -- |
- alpha = c(1, 0, 1),- |
-
105 | -- |
- size = c(2, 1, 8),- |
-
106 | -- |
- pre_output = NULL,- |
-
107 | -- |
- post_output = NULL) {- |
-
108 | -! | -
- logger::log_info("Initializing tm_a_pca")- |
-
109 | -- | - - | -
110 | -- |
- # Normalize the parameters- |
-
111 | -! | -
- if (inherits(dat, "data_extract_spec")) dat <- list(dat)- |
-
112 | -! | -
- if (inherits(ggplot2_args, "ggplot2_args")) ggplot2_args <- list(default = ggplot2_args)- |
-
113 | -- | - - | -
114 | -- |
- # Start of assertions- |
-
115 | -! | -
- checkmate::assert_string(label)- |
-
116 | -! | -
- checkmate::assert_list(dat, types = "data_extract_spec")- |
-
117 | -- | - - | -
118 | -! | -
- checkmate::assert_numeric(plot_height, len = 3, any.missing = FALSE, finite = TRUE)- |
-
119 | -! | -
- checkmate::assert_numeric(plot_height[1], lower = plot_height[2], upper = plot_height[3], .var.name = "plot_height")- |
-
120 | -! | -
- checkmate::assert_numeric(plot_width, len = 3, any.missing = FALSE, null.ok = TRUE, finite = TRUE)- |
-
121 | -! | -
- checkmate::assert_numeric(- |
-
122 | -! | -
- plot_width[1],- |
-
123 | -! | -
- lower = plot_width[2], upper = plot_width[3], null.ok = TRUE, .var.name = "plot_width"- |
-
124 | -- |
- )- |
-
125 | -- | - - | -
126 | -! | -
- ggtheme <- match.arg(ggtheme)- |
-
127 | -- | - - | -
128 | -! | -
- plot_choices <- c("Elbow plot", "Circle plot", "Biplot", "Eigenvector plot")- |
-
129 | -! | -
- checkmate::assert_list(ggplot2_args, types = "ggplot2_args")- |
-
130 | -! | -
- checkmate::assert_subset(names(ggplot2_args), c("default", plot_choices))- |
-
131 | -- | - - | -
132 | -! | -
- checkmate::assert_flag(rotate_xaxis_labels)- |
-
133 | -- | - - | -
134 | -! | -
- if (length(font_size) == 1) {- |
-
135 | -! | -
- checkmate::assert_numeric(font_size, any.missing = FALSE, finite = TRUE, lower = 8, upper = 20)- |
-
136 | -- |
- } else {- |
-
137 | -! | -
- checkmate::assert_numeric(font_size, len = 3, any.missing = FALSE, finite = TRUE, lower = 8, upper = 20)- |
-
138 | -! | -
- checkmate::assert_numeric(font_size[1], lower = font_size[2], upper = font_size[3], .var.name = "font_size")- |
-
139 | -- |
- }- |
-
140 | -- | - - | -
141 | -! | -
- if (length(alpha) == 1) {- |
-
142 | -! | -
- checkmate::assert_numeric(alpha, any.missing = FALSE, finite = TRUE, lower = 0, upper = 1)- |
-
143 | -- |
- } else {- |
-
144 | -! | -
- checkmate::assert_numeric(alpha, len = 3, any.missing = FALSE, finite = TRUE, lower = 0, upper = 1)- |
-
145 | -! | -
- checkmate::assert_numeric(alpha[1], lower = alpha[2], upper = alpha[3], .var.name = "alpha")- |
-
146 | -- |
- }- |
-
147 | -- | - - | -
148 | -! | -
- if (length(size) == 1) {- |
-
149 | -! | -
- checkmate::assert_numeric(size, any.missing = FALSE, finite = TRUE, lower = 1, upper = 8)- |
-
150 | -- |
- } else {- |
-
151 | -! | -
- checkmate::assert_numeric(size, len = 3, any.missing = FALSE, finite = TRUE, lower = 1, upper = 8)- |
-
152 | -! | -
- checkmate::assert_numeric(size[1], lower = size[2], upper = size[3], .var.name = "size")- |
-
153 | -- |
- }- |
-
154 | -- | - - | -
155 | -! | -
- checkmate::assert_multi_class(pre_output, c("shiny.tag", "shiny.tag.list", "html"), null.ok = TRUE)- |
-
156 | -! | -
- checkmate::assert_multi_class(post_output, c("shiny.tag", "shiny.tag.list", "html"), null.ok = TRUE)- |
-
157 | -- |
- # End of assertions- |
-
158 | -- | - - | -
159 | -- |
- # Make UI args- |
-
160 | -! | -
- args <- as.list(environment())- |
-
161 | -- | - - | -
162 | -! | -
- data_extract_list <- list(dat = dat)- |
-
163 | -- | - - | -
164 | -! | -
- module(- |
-
165 | -! | -
- label = label,- |
-
166 | -! | -
- server = srv_a_pca,- |
-
167 | -! | -
- ui = ui_a_pca,- |
-
168 | -! | -
- ui_args = args,- |
-
169 | -! | -
- server_args = c(- |
-
170 | -! | -
- data_extract_list,- |
-
171 | -! | -
- list(- |
-
172 | -! | -
- plot_height = plot_height,- |
-
173 | -! | -
- plot_width = plot_width,- |
-
174 | -! | -
- ggplot2_args = ggplot2_args- |
-
175 | -- |
- )- |
-
176 | -- |
- ),- |
-
177 | -! | -
- datanames = teal.transform::get_extract_datanames(data_extract_list)- |
-
178 | -- |
- )- |
-
179 | -- |
- }- |
-
180 | -- | - - | -
181 | -- |
- # UI function for the PCA module- |
-
182 | -- |
- ui_a_pca <- function(id, ...) {- |
-
183 | -! | -
- ns <- NS(id)- |
-
184 | -! | -
- args <- list(...)- |
-
185 | -! | -
- is_single_dataset_value <- teal.transform::is_single_dataset(args$dat)- |
-
186 | -- | - - | -
187 | -! | -
- color_selector <- args$dat- |
-
188 | -! | -
- for (i in seq_along(color_selector)) {- |
-
189 | -! | -
- color_selector[[i]]$select$multiple <- FALSE- |
-
190 | -! | -
- color_selector[[i]]$select$always_selected <- NULL- |
-
191 | -! | -
- color_selector[[i]]$select$selected <- NULL- |
-
192 | -- |
- }- |
-
193 | -- | - - | -
194 | -! | -
- shiny::tagList(- |
-
195 | -! | -
- include_css_files("custom"),- |
-
196 | -! | -
- teal.widgets::standard_layout(- |
-
197 | -! | -
- output = teal.widgets::white_small_well(- |
-
198 | -! | -
- uiOutput(ns("all_plots"))- |
-
199 | -- |
- ),- |
-
200 | -! | -
- encoding = div(- |
-
201 | -- |
- ### Reporter- |
-
202 | -! | -
- teal.reporter::simple_reporter_ui(ns("simple_reporter")),- |
-
203 | -- |
- ###- |
-
204 | -! | -
- tags$label("Encodings", class = "text-primary"),- |
-
205 | -! | -
- teal.transform::datanames_input(args["dat"]),- |
-
206 | -! | -
- teal.transform::data_extract_ui(- |
-
207 | -! | -
- id = ns("dat"),- |
-
208 | -! | -
- label = "Data selection",- |
-
209 | -! | -
- data_extract_spec = args$dat,- |
-
210 | -! | -
- is_single_dataset = is_single_dataset_value- |
-
211 | -- |
- ),- |
-
212 | -! | -
- teal.widgets::panel_group(- |
-
213 | -! | -
- teal.widgets::panel_item(- |
-
214 | -! | -
- title = "Display",- |
-
215 | -! | -
- collapsed = FALSE,- |
-
216 | -! | -
- checkboxGroupInput(- |
-
217 | -! | -
- ns("tables_display"),- |
-
218 | -! | -
- "Tables display",- |
-
219 | -! | -
- choices = c("PC importance" = "importance", "Eigenvectors" = "eigenvector"),- |
-
220 | -! | -
- selected = c("importance", "eigenvector")- |
-
221 | -- |
- ),- |
-
222 | -! | -
- radioButtons(- |
-
223 | -! | -
- ns("plot_type"),- |
-
224 | -! | -
- label = "Plot type",- |
-
225 | -! | -
- choices = args$plot_choices,- |
-
226 | -! | -
- selected = args$plot_choices[1]- |
-
227 | -- |
- )- |
-
228 | -- |
- ),- |
-
229 | -! | -
- teal.widgets::panel_item(- |
-
230 | -! | -
- title = "Pre-processing",- |
-
231 | -! | -
- radioButtons(- |
-
232 | -! | -
- ns("standardization"), "Standardization",- |
-
233 | -! | -
- choices = c("None" = "none", "Center" = "center", "Center & Scale" = "center_scale"),- |
-
234 | -! | -
- selected = "center_scale"- |
-
235 | -- |
- ),- |
-
236 | -! | -
- radioButtons(- |
-
237 | -! | -
- ns("na_action"), "NA action",- |
-
238 | -! | -
- choices = c("None" = "none", "Drop" = "drop"),- |
-
239 | -! | -
- selected = "none"- |
-
240 | -- |
- )- |
-
241 | -- |
- ),- |
-
242 | -! | -
- teal.widgets::panel_item(- |
-
243 | -! | -
- title = "Selected plot specific settings",- |
-
244 | -! | -
- collapsed = FALSE,- |
-
245 | -! | -
- uiOutput(ns("plot_settings")),- |
-
246 | -! | -
- conditionalPanel(- |
-
247 | -! | -
- condition = sprintf("input['%s'] == 'Biplot'", ns("plot_type")),- |
-
248 | -! | -
- list(- |
-
249 | -! | -
- teal.transform::data_extract_ui(- |
-
250 | -! | -
- id = ns("response"),- |
-
251 | -! | -
- label = "Color by",- |
-
252 | -! | -
- data_extract_spec = color_selector,- |
-
253 | -! | -
- is_single_dataset = is_single_dataset_value- |
-
254 | -- |
- ),- |
-
255 | -! | -
- teal.widgets::optionalSliderInputValMinMax(ns("alpha"), "Opacity:", args$alpha, ticks = FALSE),- |
-
256 | -! | -
- teal.widgets::optionalSliderInputValMinMax(ns("size"), "Points size:", args$size, ticks = FALSE)- |
-
257 | -- |
- )- |
-
258 | -- |
- )- |
-
259 | -- |
- ),- |
-
260 | -! | -
- teal.widgets::panel_item(- |
-
261 | -! | -
- title = "Plot settings",- |
-
262 | -! | -
- collapsed = TRUE,- |
-
263 | -! | -
- conditionalPanel(- |
-
264 | -! | -
- condition = sprintf(- |
-
265 | -! | -
- "input['%s'] == 'Elbow Plot' || input['%s'] == 'Eigenvector plot'",- |
-
266 | -! | -
- ns("plot_type"),- |
-
267 | -! | -
- ns("plot_type")- |
-
268 | -- |
- ),- |
-
269 | -! | -
- list(checkboxInput(ns("rotate_xaxis_labels"), "Rotate X axis labels", value = args$rotate_xaxis_labels))- |
-
270 | -- |
- ),- |
-
271 | -! | -
- selectInput(- |
-
272 | -! | -
- inputId = ns("ggtheme"),- |
-
273 | -! | -
- label = "Theme (by ggplot):",- |
-
274 | -! | -
- choices = ggplot_themes,- |
-
275 | -! | -
- selected = args$ggtheme,- |
-
276 | -! | -
- multiple = FALSE- |
-
277 | -- |
- ),- |
-
278 | -! | -
- teal.widgets::optionalSliderInputValMinMax(ns("font_size"), "Font Size", args$font_size, ticks = FALSE)- |
-
279 | -- |
- )- |
-
280 | -- |
- )- |
-
281 | -- |
- ),- |
-
282 | -! | -
- forms = tagList(- |
-
283 | -! | -
- teal.widgets::verbatim_popup_ui(ns("warning"), "Show Warnings"),- |
-
284 | -! | -
- teal.widgets::verbatim_popup_ui(ns("rcode"), "Show R code")- |
-
285 | -- |
- ),- |
-
286 | -! | -
- pre_output = args$pre_output,- |
-
287 | -! | -
- post_output = args$post_output- |
-
288 | -- |
- )- |
-
289 | -- |
- )- |
-
290 | -- |
- }- |
-
291 | -- | - - | -
292 | -- |
- # Server function for the PCA module- |
-
293 | -- |
- srv_a_pca <- function(id, data, reporter, filter_panel_api, dat, plot_height, plot_width, ggplot2_args) {- |
-
294 | -! | -
- with_reporter <- !missing(reporter) && inherits(reporter, "Reporter")- |
-
295 | -! | -
- with_filter <- !missing(filter_panel_api) && inherits(filter_panel_api, "FilterPanelAPI")- |
-
296 | -! | -
- checkmate::assert_class(data, "reactive")- |
-
297 | -! | -
- checkmate::assert_class(isolate(data()), "teal_data")- |
-
298 | -! | -
- moduleServer(id, function(input, output, session) {- |
-
299 | -! | -
- response <- dat- |
-
300 | -- | - - | -
301 | -! | -
- for (i in seq_along(response)) {- |
-
302 | -! | -
- response[[i]]$select$multiple <- FALSE- |
-
303 | -! | -
- response[[i]]$select$always_selected <- NULL- |
-
304 | -! | -
- response[[i]]$select$selected <- NULL- |
-
305 | -! | -
- all_cols <- teal.data::col_labels(isolate(data())[[response[[i]]$dataname]])- |
-
306 | -! | -
- ignore_cols <- unlist(teal.data::join_keys(isolate(data()))[[response[[i]]$dataname]])- |
-
307 | -! | -
- color_cols <- all_cols[!names(all_cols) %in% ignore_cols]- |
-
308 | -! | -
- response[[i]]$select$choices <- choices_labeled(names(color_cols), color_cols)- |
-
309 | -- |
- }- |
-
310 | -- | - - | -
311 | -! | -
- selector_list <- teal.transform::data_extract_multiple_srv(- |
-
312 | -! | -
- data_extract = list(dat = dat, response = response),- |
-
313 | -! | -
- datasets = data,- |
-
314 | -! | -
- select_validation_rule = list(- |
-
315 | -! | -
- dat = ~ if (length(.) < 2L) "Please select more than 1 variable to perform PCA.",- |
-
316 | -! | -
- response = shinyvalidate::compose_rules(- |
-
317 | -! | -
- shinyvalidate::sv_optional(),- |
-
318 | -! | -
- ~ if (isTRUE(is.element(., selector_list()$dat()$select))) {- |
-
319 | -! | -
- "Response must not have been used for PCA."- |
-
320 | -- |
- }- |
-
321 | -- |
- )- |
-
322 | -- |
- )- |
-
323 | -- |
- )- |
-
324 | -- | - - | -
325 | -! | -
- iv_r <- reactive({- |
-
326 | -! | -
- iv <- shinyvalidate::InputValidator$new()- |
-
327 | -! | -
- teal.transform::compose_and_enable_validators(iv, selector_list)- |
-
328 | -- |
- })- |
-
329 | -- | - - | -
330 | -! | -
- iv_extra <- shinyvalidate::InputValidator$new()- |
-
331 | -! | -
- iv_extra$add_rule("x_axis", function(value) {- |
-
332 | -! | -
- if (isTRUE(input$plot_type %in% c("Circle plot", "Biplot"))) {- |
-
333 | -! | -
- if (!shinyvalidate::input_provided(value)) {- |
-
334 | -! | -
- "Need X axis"- |
-
335 | -- |
- }- |
-
336 | -- |
- }- |
-
337 | -- |
- })- |
-
338 | -! | -
- iv_extra$add_rule("y_axis", function(value) {- |
-
339 | -! | -
- if (isTRUE(input$plot_type %in% c("Circle plot", "Biplot"))) {- |
-
340 | -! | -
- if (!shinyvalidate::input_provided(value)) {- |
-
341 | -! | -
- "Need Y axis"- |
-
342 | -- |
- }- |
-
343 | -- |
- }- |
-
344 | -- |
- })- |
-
345 | -! | -
- rule_dupl <- function(...) {- |
-
346 | -! | -
- if (isTRUE(input$plot_type %in% c("Circle plot", "Biplot"))) {- |
-
347 | -! | -
- if (isTRUE(input$x_axis == input$y_axis)) {- |
-
348 | -! | -
- "Please choose different X and Y axes."- |
-
349 | -- |
- }- |
-
350 | -- |
- }- |
-
351 | -- |
- }- |
-
352 | -! | -
- iv_extra$add_rule("x_axis", rule_dupl)- |
-
353 | -! | -
- iv_extra$add_rule("y_axis", rule_dupl)- |
-
354 | -! | -
- iv_extra$add_rule("variables", function(value) {- |
-
355 | -! | -
- if (identical(input$plot_type, "Circle plot")) {- |
-
356 | -! | -
- if (!shinyvalidate::input_provided(value)) {- |
-
357 | -! | -
- "Need Original Coordinates"- |
-
358 | -- |
- }- |
-
359 | -- |
- }- |
-
360 | -- |
- })- |
-
361 | -! | -
- iv_extra$add_rule("pc", function(value) {- |
-
362 | -! | -
- if (identical(input$plot_type, "Eigenvector plot")) {- |
-
363 | -! | -
- if (!shinyvalidate::input_provided(value)) {- |
-
364 | -! | -
- "Need PC"- |
-
365 | -- |
- }- |
-
366 | -- |
- }- |
-
367 | -- |
- })- |
-
368 | -! | -
- iv_extra$enable()- |
-
369 | -- | - - | -
370 | -! | -
- anl_merged_input <- teal.transform::merge_expression_srv(- |
-
371 | -! | -
- selector_list = selector_list,- |
-
372 | -! | -
- datasets = data- |
-
373 | -- |
- )- |
-
374 | -- | - - | -
375 | -! | -
- anl_merged_q <- reactive({- |
-
376 | -! | -
- req(anl_merged_input())- |
-
377 | -! | -
- data() %>%- |
-
378 | -! | -
- teal.code::eval_code(as.expression(anl_merged_input()$expr))- |
-
379 | -- |
- })- |
-
380 | -- | - - | -
381 | -! | -
- merged <- list(- |
-
382 | -! | -
- anl_input_r = anl_merged_input,- |
-
383 | -! | -
- anl_q_r = anl_merged_q- |
-
384 | -- |
- )- |
-
385 | -- | - - | -
386 | -! | -
- validation <- reactive({- |
-
387 | -! | -
- req(merged$anl_q_r())- |
-
388 | -- |
- # inputs- |
-
389 | -! | -
- keep_cols <- as.character(merged$anl_input_r()$columns_source$dat)- |
-
390 | -! | -
- na_action <- input$na_action- |
-
391 | -! | -
- standardization <- input$standardization- |
-
392 | -! | -
- center <- standardization %in% c("center", "center_scale")- |
-
393 | -! | -
- scale <- standardization == "center_scale"- |
-
394 | -! | -
- ANL <- merged$anl_q_r()[["ANL"]]- |
-
395 | -- | - - | -
396 | -! | -
- teal::validate_has_data(ANL, 10)- |
-
397 | -! | -
- validate(need(- |
-
398 | -! | -
- na_action != "none" | !anyNA(ANL[keep_cols]),- |
-
399 | -! | -
- paste(- |
-
400 | -! | -
- "There are NAs in the dataset. Please deal with them in preprocessing",- |
-
401 | -! | -
- "or select \"Drop\" in the NA actions inside the encodings panel (left)."- |
-
402 | -- |
- )- |
-
403 | -- |
- ))- |
-
404 | -! | -
- if (scale) {- |
-
405 | -! | -
- not_single <- vapply(ANL[keep_cols], function(column) length(unique(column)) != 1, FUN.VALUE = logical(1))- |
-
406 | -- | - - | -
407 | -! | -
- msg <- paste0(- |
-
408 | -! | -
- "You have selected `Center & Scale` under `Standardization` in the `Pre-processing` panel, ",- |
-
409 | -! | -
- "but one or more of your columns has/have a variance value of zero, indicating all values are identical"- |
-
410 | -- |
- )- |
-
411 | -! | -
- validate(need(all(not_single), msg))- |
-
412 | -- |
- }- |
-
413 | -- |
- })- |
-
414 | -- | - - | -
415 | -- |
- # computation ----- |
-
416 | -! | -
- computation <- reactive({- |
-
417 | -! | -
- validation()- |
-
418 | -- | - - | -
419 | -- |
- # inputs- |
-
420 | -! | -
- keep_cols <- as.character(merged$anl_input_r()$columns_source$dat)- |
-
421 | -! | -
- na_action <- input$na_action- |
-
422 | -! | -
- standardization <- input$standardization- |
-
423 | -! | -
- center <- standardization %in% c("center", "center_scale")- |
-
424 | -! | -
- scale <- standardization == "center_scale"- |
-
425 | -! | -
- ANL <- merged$anl_q_r()[["ANL"]]- |
-
426 | -- | - - | -
427 | -! | -
- qenv <- teal.code::eval_code(- |
-
428 | -! | -
- merged$anl_q_r(),- |
-
429 | -! | -
- substitute(- |
-
430 | -! | -
- expr = keep_columns <- keep_cols,- |
-
431 | -! | -
- env = list(keep_cols = keep_cols)- |
-
432 | -- |
- )- |
-
433 | -- |
- )- |
-
434 | -- | - - | -
435 | -! | -
- if (na_action == "drop") {- |
-
436 | -! | -
- qenv <- teal.code::eval_code(- |
-
437 | -! | -
- qenv,- |
-
438 | -! | -
- quote(ANL <- tidyr::drop_na(ANL, keep_columns))- |
-
439 | -- |
- )- |
-
440 | -- |
- }- |
-
441 | -- | - - | -
442 | -! | -
- qenv <- teal.code::eval_code(- |
-
443 | -! | -
- qenv,- |
-
444 | -! | -
- substitute(- |
-
445 | -! | -
- expr = pca <- summary(stats::prcomp(ANL[keep_columns], center = center, scale. = scale, retx = TRUE)),- |
-
446 | -! | -
- env = list(center = center, scale = scale)- |
-
447 | -- |
- )- |
-
448 | -- |
- )- |
-
449 | -- | - - | -
450 | -! | -
- qenv <- teal.code::eval_code(- |
-
451 | -! | -
- qenv,- |
-
452 | -! | -
- quote({- |
-
453 | -! | -
- tbl_importance <- dplyr::as_tibble(pca$importance, rownames = "Metric")- |
-
454 | -! | -
- tbl_importance- |
-
455 | -- |
- })- |
-
456 | -- |
- )- |
-
457 | -- | - - | -
458 | -! | -
- teal.code::eval_code(- |
-
459 | -! | -
- qenv,- |
-
460 | -! | -
- quote({- |
-
461 | -! | -
- tbl_eigenvector <- dplyr::as_tibble(pca$rotation, rownames = "Variable")- |
-
462 | -! | -
- tbl_eigenvector- |
-
463 | -- |
- })- |
-
464 | -- |
- )- |
-
465 | -- |
- })- |
-
466 | -- | - - | -
467 | -- |
- # plot args ----- |
-
468 | -! | -
- output$plot_settings <- renderUI({- |
-
469 | -- |
- # reactivity triggers- |
-
470 | -! | -
- req(iv_r()$is_valid())- |
-
471 | -! | -
- req(computation())- |
-
472 | -! | -
- qenv <- computation()- |
-
473 | -- | - - | -
474 | -! | -
- ns <- session$ns- |
-
475 | -- | - - | -
476 | -! | -
- pca <- qenv[["pca"]]- |
-
477 | -! | -
- chcs_pcs <- colnames(pca$rotation)- |
-
478 | -! | -
- chcs_vars <- qenv[["keep_columns"]]- |
-
479 | -- | - - | -
480 | -! | -
- tagList(- |
-
481 | -! | -
- conditionalPanel(- |
-
482 | -! | -
- condition = sprintf(- |
-
483 | -! | -
- "input['%s'] == 'Biplot' || input['%s'] == 'Circle plot'",- |
-
484 | -! | -
- ns("plot_type"), ns("plot_type")- |
-
485 | -- |
- ),- |
-
486 | -! | -
- list(- |
-
487 | -! | -
- teal.widgets::optionalSelectInput(ns("x_axis"), "X axis", choices = chcs_pcs, selected = chcs_pcs[1]),- |
-
488 | -! | -
- teal.widgets::optionalSelectInput(ns("y_axis"), "Y axis", choices = chcs_pcs, selected = chcs_pcs[2]),- |
-
489 | -! | -
- teal.widgets::optionalSelectInput(- |
-
490 | -! | -
- ns("variables"), "Original coordinates",- |
-
491 | -! | -
- choices = chcs_vars, selected = chcs_vars,- |
-
492 | -! | -
- multiple = TRUE- |
-
493 | -- |
- )- |
-
494 | -- |
- )- |
-
495 | -- |
- ),- |
-
496 | -! | -
- conditionalPanel(- |
-
497 | -! | -
- condition = sprintf("input['%s'] == 'Elbow plot'", ns("plot_type")),- |
-
498 | -! | -
- helpText("No plot specific settings available.")- |
-
499 | -- |
- ),- |
-
500 | -! | -
- conditionalPanel(- |
-
501 | -! | -
- condition = paste0("input['", ns("plot_type"), "'] == 'Eigenvector plot'"),- |
-
502 | -! | -
- teal.widgets::optionalSelectInput(ns("pc"), "PC", choices = chcs_pcs, selected = chcs_pcs[1])- |
-
503 | -- |
- )- |
-
504 | -- |
- )- |
-
505 | -- |
- })- |
-
506 | -- | - - | -
507 | -- |
- # plot elbow ----- |
-
508 | -! | -
- plot_elbow <- function(base_q) {- |
-
509 | -! | -
- ggtheme <- input$ggtheme- |
-
510 | -! | -
- rotate_xaxis_labels <- input$rotate_xaxis_labels- |
-
511 | -! | -
- font_size <- input$font_size- |
-
512 | -- | - - | -
513 | -! | -
- angle_value <- ifelse(isTRUE(rotate_xaxis_labels), 45, 0)- |
-
514 | -! | -
- hjust_value <- ifelse(isTRUE(rotate_xaxis_labels), 1, 0.5)- |
-
515 | -- | - - | -
516 | -! | -
- dev_ggplot2_args <- teal.widgets::ggplot2_args(- |
-
517 | -! | -
- labs = list(x = "Principal component", y = "Proportion of variance explained", color = "", fill = "Legend"),- |
-
518 | -! | -
- theme = list(- |
-
519 | -! | -
- legend.position = "right",- |
-
520 | -! | -
- legend.spacing.y = quote(grid::unit(-5, "pt")),- |
-
521 | -! | -
- legend.title = quote(element_text(vjust = 25)),- |
-
522 | -! | -
- axis.text.x = substitute(- |
-
523 | -! | -
- element_text(angle = angle_value, hjust = hjust_value),- |
-
524 | -! | -
- list(angle_value = angle_value, hjust_value = hjust_value)- |
-
525 | -- |
- ),- |
-
526 | -! | -
- text = substitute(element_text(size = font_size), list(font_size = font_size))- |
-
527 | -- |
- )- |
-
528 | -- |
- )- |
-
529 | -- | - - | -
530 | -! | -
- parsed_ggplot2_args <- teal.widgets::parse_ggplot2_args(- |
-
531 | -! | -
- teal.widgets::resolve_ggplot2_args(- |
-
532 | -! | -
- user_plot = ggplot2_args[["Elbow plot"]],- |
-
533 | -! | -
- user_default = ggplot2_args$default,- |
-
534 | -! | -
- module_plot = dev_ggplot2_args- |
-
535 | -- |
- ),- |
-
536 | -! | -
- ggtheme = ggtheme- |
-
537 | -- |
- )- |
-
538 | -- | - - | -
539 | -! | -
- teal.code::eval_code(- |
-
540 | -! | -
- base_q,- |
-
541 | -! | -
- substitute(- |
-
542 | -! | -
- expr = {- |
-
543 | -! | -
- elb_dat <- pca$importance[c("Proportion of Variance", "Cumulative Proportion"), ] %>%- |
-
544 | -! | -
- dplyr::as_tibble(rownames = "metric") %>%- |
-
545 | -! | -
- tidyr::gather("component", "value", -metric) %>%- |
-
546 | -! | -
- dplyr::mutate(- |
-
547 | -! | -
- component = factor(component, levels = unique(stringr::str_sort(component, numeric = TRUE)))- |
-
548 | -- |
- )- |
-
549 | -- | - - | -
550 | -! | -
- cols <- c(getOption("ggplot2.discrete.colour"), c("lightblue", "darkred", "black"))[1:3]- |
-
551 | -! | -
- g <- ggplot(mapping = aes_string(x = "component", y = "value")) +- |
-
552 | -! | -
- geom_bar(- |
-
553 | -! | -
- aes(fill = "Single variance"),- |
-
554 | -! | -
- data = dplyr::filter(elb_dat, metric == "Proportion of Variance"),- |
-
555 | -! | -
- color = "black",- |
-
556 | -! | -
- stat = "identity"- |
-
557 | -- |
- ) +- |
-
558 | -! | -
- geom_point(- |
-
559 | -! | -
- aes(color = "Cumulative variance"),- |
-
560 | -! | -
- data = dplyr::filter(elb_dat, metric == "Cumulative Proportion")- |
-
561 | -- |
- ) +- |
-
562 | -! | -
- geom_line(- |
-
563 | -! | -
- aes(group = 1, color = "Cumulative variance"),- |
-
564 | -! | -
- data = dplyr::filter(elb_dat, metric == "Cumulative Proportion")- |
-
565 | -- |
- ) +- |
-
566 | -! | -
- labs +- |
-
567 | -! | -
- scale_color_manual(values = c("Cumulative variance" = cols[2], "Single variance" = cols[3])) +- |
-
568 | -! | -
- scale_fill_manual(values = c("Cumulative variance" = cols[2], "Single variance" = cols[1])) +- |
-
569 | -! | -
- ggthemes +- |
-
570 | -! | -
- themes- |
-
571 | -- | - - | -
572 | -! | -
- print(g)- |
-
573 | -- |
- },- |
-
574 | -! | -
- env = list(- |
-
575 | -! | -
- ggthemes = parsed_ggplot2_args$ggtheme,- |
-
576 | -! | -
- labs = parsed_ggplot2_args$labs,- |
-
577 | -! | -
- themes = parsed_ggplot2_args$theme- |
-
578 | -- |
- )- |
-
579 | -- |
- )- |
-
580 | -- |
- )- |
-
581 | -- |
- }- |
-
582 | -- | - - | -
583 | -- |
- # plot circle ----- |
-
584 | -! | -
- plot_circle <- function(base_q) {- |
-
585 | -! | -
- x_axis <- input$x_axis- |
-
586 | -! | -
- y_axis <- input$y_axis- |
-
587 | -! | -
- variables <- input$variables- |
-
588 | -! | -
- ggtheme <- input$ggtheme- |
-
589 | -- | - - | -
590 | -! | -
- rotate_xaxis_labels <- input$rotate_xaxis_labels- |
-
591 | -! | -
- font_size <- input$font_size- |
-
592 | -- | - - | -
593 | -! | -
- angle <- ifelse(isTRUE(rotate_xaxis_labels), 45, 0)- |
-
594 | -! | -
- hjust <- ifelse(isTRUE(rotate_xaxis_labels), 1, 0.5)- |
-
595 | -- | - - | -
596 | -! | -
- dev_ggplot2_args <- teal.widgets::ggplot2_args(- |
-
597 | -! | -
- theme = list(- |
-
598 | -! | -
- text = substitute(element_text(size = font_size), list(font_size = font_size)),- |
-
599 | -! | -
- axis.text.x = substitute(- |
-
600 | -! | -
- element_text(angle = angle_val, hjust = hjust_val),- |
-
601 | -! | -
- list(angle_val = angle, hjust_val = hjust)- |
-
602 | -- |
- )- |
-
603 | -- |
- )- |
-
604 | -- |
- )- |
-
605 | -- | - - | -
606 | -! | -
- all_ggplot2_args <- teal.widgets::resolve_ggplot2_args(- |
-
607 | -! | -
- user_plot = ggplot2_args[["Circle plot"]],- |
-
608 | -! | -
- user_default = ggplot2_args$default,- |
-
609 | -! | -
- module_plot = dev_ggplot2_args- |
-
610 | -- |
- )- |
-
611 | -- | - - | -
612 | -! | -
- parsed_ggplot2_args <- teal.widgets::parse_ggplot2_args(- |
-
613 | -! | -
- all_ggplot2_args,- |
-
614 | -! | -
- ggtheme = ggtheme- |
-
615 | -- |
- )- |
-
616 | -- | - - | -
617 | -! | -
- teal.code::eval_code(- |
-
618 | -! | -
- base_q,- |
-
619 | -! | -
- substitute(- |
-
620 | -! | -
- expr = {- |
-
621 | -! | -
- pca_rot <- pca$rotation[, c(x_axis, y_axis)] %>%- |
-
622 | -! | -
- dplyr::as_tibble(rownames = "label") %>%- |
-
623 | -! | -
- dplyr::filter(label %in% variables)- |
-
624 | -- | - - | -
625 | -! | -
- circle_data <- data.frame(- |
-
626 | -! | -
- x = cos(seq(0, 2 * pi, length.out = 100)),- |
-
627 | -! | -
- y = sin(seq(0, 2 * pi, length.out = 100))- |
-
628 | -- |
- )- |
-
629 | -- | - - | -
630 | -! | -
- g <- ggplot(pca_rot) +- |
-
631 | -! | -
- geom_point(aes_string(x = x_axis, y = y_axis)) +- |
-
632 | -! | -
- geom_label(- |
-
633 | -! | -
- aes_string(x = x_axis, y = y_axis, label = "label"),- |
-
634 | -! | -
- nudge_x = 0.1, nudge_y = 0.05,- |
-
635 | -! | -
- fontface = "bold"- |
-
636 | -- |
- ) +- |
-
637 | -! | -
- geom_path(aes(x, y, group = 1), data = circle_data) +- |
-
638 | -! | -
- geom_point(aes(x = x, y = y), data = data.frame(x = 0, y = 0), shape = "x", size = 5) +- |
-
639 | -! | -
- labs +- |
-
640 | -! | -
- ggthemes +- |
-
641 | -! | -
- themes- |
-
642 | -! | -
- print(g)- |
-
643 | -- |
- },- |
-
644 | -! | -
- env = list(- |
-
645 | -! | -
- x_axis = x_axis,- |
-
646 | -! | -
- y_axis = y_axis,- |
-
647 | -! | -
- variables = variables,- |
-
648 | -! | -
- ggthemes = parsed_ggplot2_args$ggtheme,- |
-
649 | -! | -
- labs = `if`(is.null(parsed_ggplot2_args$labs), quote(labs()), parsed_ggplot2_args$labs),- |
-
650 | -! | -
- themes = parsed_ggplot2_args$theme- |
-
651 | -- |
- )- |
-
652 | -- |
- )- |
-
653 | -- |
- )- |
-
654 | -- |
- }- |
-
655 | -- | - - | -
656 | -- |
- # plot biplot ----- |
-
657 | -! | -
- plot_biplot <- function(base_q) {- |
-
658 | -! | -
- qenv <- base_q- |
-
659 | -- | - - | -
660 | -! | -
- ANL <- qenv[["ANL"]]- |
-
661 | -- | - - | -
662 | -! | -
- resp_col <- as.character(merged$anl_input_r()$columns_source$response)- |
-
663 | -! | -
- dat_cols <- as.character(merged$anl_input_r()$columns_source$dat)- |
-
664 | -! | -
- x_axis <- input$x_axis- |
-
665 | -! | -
- y_axis <- input$y_axis- |
-
666 | -! | -
- variables <- input$variables- |
-
667 | -! | -
- pca <- qenv[["pca"]]- |
-
668 | -- | - - | -
669 | -! | -
- ggtheme <- input$ggtheme- |
-
670 | -- | - - | -
671 | -! | -
- rotate_xaxis_labels <- input$rotate_xaxis_labels- |
-
672 | -! | -
- alpha <- input$alpha- |
-
673 | -! | -
- size <- input$size- |
-
674 | -! | -
- font_size <- input$font_size- |
-
675 | -- | - - | -
676 | -! | -
- qenv <- teal.code::eval_code(- |
-
677 | -! | -
- qenv,- |
-
678 | -! | -
- substitute(- |
-
679 | -! | -
- expr = pca_rot <- dplyr::as_tibble(pca$x[, c(x_axis, y_axis)]),- |
-
680 | -! | -
- env = list(x_axis = x_axis, y_axis = y_axis)- |
-
681 | -- |
- )- |
-
682 | -- |
- )- |
-
683 | -- | - - | -
684 | -- |
- # rot_vars = data frame that displays arrows in the plot, need to be scaled to data- |
-
685 | -! | -
- if (!is.null(input$variables)) {- |
-
686 | -! | -
- qenv <- teal.code::eval_code(- |
-
687 | -! | -
- qenv,- |
-
688 | -! | -
- substitute(- |
-
689 | -! | -
- expr = {- |
-
690 | -! | -
- r <- sqrt(qchisq(0.69, df = 2)) * prod(colMeans(pca_rot ^ 2)) ^ (1 / 4) # styler: off- |
-
691 | -! | -
- v_scale <- rowSums(pca$rotation ^ 2) # styler: off- |
-
692 | -- | - - | -
693 | -! | -
- rot_vars <- pca$rotation[, c(x_axis, y_axis)] %>%- |
-
694 | -! | -
- dplyr::as_tibble(rownames = "label") %>%- |
-
695 | -! | -
- dplyr::mutate_at(vars(c(x_axis, y_axis)), function(x) r * x / sqrt(max(v_scale)))- |
-
696 | -- |
- },- |
-
697 | -! | -
- env = list(x_axis = x_axis, y_axis = y_axis)- |
-
698 | -- |
- )- |
-
699 | -- |
- ) %>%- |
-
700 | -! | -
- teal.code::eval_code(- |
-
701 | -! | -
- if (is.logical(pca$center) && !pca$center) {- |
-
702 | -! | -
- substitute(- |
-
703 | -! | -
- expr = {- |
-
704 | -! | -
- rot_vars <- rot_vars %>%- |
-
705 | -! | -
- tibble::column_to_rownames("label") %>%- |
-
706 | -! | -
- sweep(1, apply(ANL[keep_columns], 2, mean, na.rm = TRUE)) %>%- |
-
707 | -! | -
- tibble::rownames_to_column("label") %>%- |
-
708 | -! | -
- dplyr::mutate(- |
-
709 | -! | -
- xstart = mean(pca$x[, x_axis], na.rm = TRUE),- |
-
710 | -! | -
- ystart = mean(pca$x[, y_axis], na.rm = TRUE)- |
-
711 | -- |
- )- |
-
712 | -- |
- },- |
-
713 | -! | -
- env = list(x_axis = x_axis, y_axis = y_axis)- |
-
714 | -- |
- )- |
-
715 | -- |
- } else {- |
-
716 | -! | -
- quote(rot_vars <- rot_vars %>% dplyr::mutate(xstart = 0, ystart = 0))- |
-
717 | -- |
- }- |
-
718 | -- |
- ) %>%- |
-
719 | -! | -
- teal.code::eval_code(- |
-
720 | -! | -
- substitute(- |
-
721 | -! | -
- expr = rot_vars <- rot_vars %>% dplyr::filter(label %in% variables),- |
-
722 | -! | -
- env = list(variables = variables)- |
-
723 | -- |
- )- |
-
724 | -- |
- )- |
-
725 | -- |
- }- |
-
726 | -- | - - | -
727 | -! | -
- pca_plot_biplot_expr <- list(quote(ggplot()))- |
-
728 | -- | - - | -
729 | -! | -
- if (length(resp_col) == 0) {- |
-
730 | -! | -
- pca_plot_biplot_expr <- c(- |
-
731 | -! | -
- pca_plot_biplot_expr,- |
-
732 | -! | -
- substitute(- |
-
733 | -! | -
- geom_point(aes_string(x = x_axis, y = y_axis), data = pca_rot, alpha = alpha, size = size),- |
-
734 | -! | -
- list(x_axis = input$x_axis, y_axis = input$y_axis, alpha = input$alpha, size = input$size)- |
-
735 | -- |
- )- |
-
736 | -- |
- )- |
-
737 | -! | -
- dev_labs <- list()- |
-
738 | -- |
- } else {- |
-
739 | -! | -
- rp_keys <- setdiff(colnames(ANL), as.character(unlist(merged$anl_input_r()$columns_source)))- |
-
740 | -- | - - | -
741 | -! | -
- response <- ANL[[resp_col]]- |
-
742 | -- | - - | -
743 | -! | -
- aes_biplot <- substitute(- |
-
744 | -! | -
- aes_string(x = x_axis, y = y_axis, color = "response"),- |
-
745 | -! | -
- env = list(x_axis = x_axis, y_axis = y_axis)- |
-
746 | -- |
- )- |
-
747 | -- | - - | -
748 | -! | -
- qenv <- teal.code::eval_code(- |
-
749 | -! | -
- qenv,- |
-
750 | -! | -
- substitute(response <- ANL[[resp_col]], env = list(resp_col = resp_col))- |
-
751 | -- |
- )- |
-
752 | -- | - - | -
753 | -! | -
- dev_labs <- list(color = varname_w_label(resp_col, ANL))- |
-
754 | -- | - - | -
755 | -! | -
- scales_biplot <-- |
-
756 | -! | -
- if (is.character(response) || is.factor(response) || (is.numeric(response) && length(unique(response)) <= 6)) { # nolint: line_length.- |
-
757 | -! | -
- qenv <- teal.code::eval_code(- |
-
758 | -! | -
- qenv,- |
-
759 | -! | -
- quote(pca_rot$response <- as.factor(response))- |
-
760 | -- |
- )- |
-
761 | -! | -
- quote(scale_color_brewer(palette = "Dark2"))- |
-
762 | -! | -
- } else if (inherits(response, "Date")) {- |
-
763 | -! | -
- qenv <- teal.code::eval_code(- |
-
764 | -! | -
- qenv,- |
-
765 | -! | -
- quote(pca_rot$response <- numeric(response))- |
-
766 | -- |
- )- |
-
767 | -- | - - | -
768 | -! | -
- quote(- |
-
769 | -! | -
- scale_color_gradient(- |
-
770 | -! | -
- low = c(getOption("ggplot2.discrete.colour")[2], "darkred")[1],- |
-
771 | -! | -
- high = c(getOption("ggplot2.discrete.colour"), "lightblue")[1],- |
-
772 | -! | -
- labels = function(x) as.Date(x, origin = "1970-01-01")- |
-
773 | -- |
- )- |
-
774 | -- |
- )- |
-
775 | -- |
- } else {- |
-
776 | -! | -
- qenv <- teal.code::eval_code(- |
-
777 | -! | -
- qenv,- |
-
778 | -! | -
- quote(pca_rot$response <- response)- |
-
779 | -- |
- )- |
-
780 | -! | -
- quote(scale_color_gradient(- |
-
781 | -! | -
- low = c(getOption("ggplot2.discrete.colour")[2], "darkred")[1],- |
-
782 | -! | -
- high = c(getOption("ggplot2.discrete.colour"), "lightblue")[1]- |
-
783 | -- |
- ))- |
-
784 | -- |
- }- |
-
785 | -- | - - | -
786 | -! | -
- pca_plot_biplot_expr <- c(- |
-
787 | -! | -
- pca_plot_biplot_expr,- |
-
788 | -! | -
- substitute(- |
-
789 | -! | -
- geom_point(aes_biplot, data = pca_rot, alpha = alpha, size = size),- |
-
790 | -! | -
- env = list(aes_biplot = aes_biplot, alpha = alpha, size = size)- |
-
791 | -- |
- ),- |
-
792 | -! | -
- scales_biplot- |
-
793 | -- |
- )- |
-
794 | -- |
- }- |
-
795 | -- | - - | -
796 | -! | -
- if (!is.null(input$variables)) {- |
-
797 | -! | -
- pca_plot_biplot_expr <- c(- |
-
798 | -! | -
- pca_plot_biplot_expr,- |
-
799 | -! | -
- substitute(- |
-
800 | -! | -
- geom_segment(- |
-
801 | -! | -
- aes_string(x = "xstart", y = "ystart", xend = x_axis, yend = y_axis),- |
-
802 | -! | -
- data = rot_vars,- |
-
803 | -! | -
- lineend = "round", linejoin = "round",- |
-
804 | -! | -
- arrow = grid::arrow(length = grid::unit(0.5, "cm"))- |
-
805 | -- |
- ),- |
-
806 | -! | -
- env = list(x_axis = x_axis, y_axis = y_axis)- |
-
807 | -- |
- ),- |
-
808 | -! | -
- substitute(- |
-
809 | -! | -
- geom_label(- |
-
810 | -! | -
- aes_string(- |
-
811 | -! | -
- x = x_axis,- |
-
812 | -! | -
- y = y_axis,- |
-
813 | -! | -
- label = "label"- |
-
814 | -- |
- ),- |
-
815 | -! | -
- data = rot_vars,- |
-
816 | -! | -
- nudge_y = 0.1,- |
-
817 | -! | -
- fontface = "bold"- |
-
818 | -- |
- ),- |
-
819 | -! | -
- env = list(x_axis = x_axis, y_axis = y_axis)- |
-
820 | -- |
- ),- |
-
821 | -! | -
- quote(geom_point(aes(x = xstart, y = ystart), data = rot_vars, shape = "x", size = 5))- |
-
822 | -- |
- )- |
-
823 | -- |
- }- |
-
824 | -- | - - | -
825 | -! | -
- angle <- ifelse(isTRUE(rotate_xaxis_labels), 45, 0)- |
-
826 | -! | -
- hjust <- ifelse(isTRUE(rotate_xaxis_labels), 1, 0.5)- |
-
827 | -- | - - | -
828 | -! | -
- dev_ggplot2_args <- teal.widgets::ggplot2_args(- |
-
829 | -! | -
- labs = dev_labs,- |
-
830 | -! | -
- theme = list(- |
-
831 | -! | -
- text = substitute(element_text(size = font_size), list(font_size = font_size)),- |
-
832 | -! | -
- axis.text.x = substitute(- |
-
833 | -! | -
- element_text(angle = angle_val, hjust = hjust_val),- |
-
834 | -! | -
- list(angle_val = angle, hjust_val = hjust)- |
-
835 | -- |
- )- |
-
836 | -- |
- )- |
-
837 | -- |
- )- |
-
838 | -- | - - | -
839 | -! | -
- all_ggplot2_args <- teal.widgets::resolve_ggplot2_args(- |
-
840 | -! | -
- user_plot = ggplot2_args[["Biplot"]],- |
-
841 | -! | -
- user_default = ggplot2_args$default,- |
-
842 | -! | -
- module_plot = dev_ggplot2_args- |
-
843 | -- |
- )- |
-
844 | -- | - - | -
845 | -! | -
- parsed_ggplot2_args <- teal.widgets::parse_ggplot2_args(- |
-
846 | -! | -
- all_ggplot2_args,- |
-
847 | -! | -
- ggtheme = ggtheme- |
-
848 | -- |
- )- |
-
849 | -- | - - | -
850 | -! | -
- pca_plot_biplot_expr <- c(- |
-
851 | -! | -
- pca_plot_biplot_expr,- |
-
852 | -! | -
- parsed_ggplot2_args- |
-
853 | -- |
- )- |
-
854 | -- | - - | -
855 | -! | -
- teal.code::eval_code(- |
-
856 | -! | -
- qenv,- |
-
857 | -! | -
- substitute(- |
-
858 | -! | -
- expr = {- |
-
859 | -! | -
- g <- plot_call- |
-
860 | -! | -
- print(g)- |
-
861 | -- |
- },- |
-
862 | -! | -
- env = list(- |
-
863 | -! | -
- plot_call = Reduce(function(x, y) call("+", x, y), pca_plot_biplot_expr)- |
-
864 | -- |
- )- |
-
865 | -- |
- )- |
-
866 | -- |
- )- |
-
867 | -- |
- }- |
-
868 | -- | - - | -
869 | -- |
- # plot pc_var ----- |
-
870 | -! | -
- plot_pc_var <- function(base_q) {- |
-
871 | -! | -
- pc <- input$pc- |
-
872 | -! | -
- ggtheme <- input$ggtheme- |
-
873 | -- | - - | -
874 | -! | -
- rotate_xaxis_labels <- input$rotate_xaxis_labels- |
-
875 | -! | -
- font_size <- input$font_size- |
-
876 | -- | - - | -
877 | -! | -
- angle <- ifelse(rotate_xaxis_labels, 45, 0)- |
-
878 | -! | -
- hjust <- ifelse(rotate_xaxis_labels, 1, 0.5)- |
-
879 | -- | - - | -
880 | -! | -
- dev_ggplot2_args <- teal.widgets::ggplot2_args(- |
-
881 | -! | -
- theme = list(- |
-
882 | -! | -
- text = substitute(element_text(size = font_size), list(font_size = font_size)),- |
-
883 | -! | -
- axis.text.x = substitute(- |
-
884 | -! | -
- element_text(angle = angle_val, hjust = hjust_val),- |
-
885 | -! | -
- list(angle_val = angle, hjust_val = hjust)- |
-
886 | -- |
- )- |
-
887 | -- |
- )- |
-
888 | -- |
- )- |
-
889 | -- | - - | -
890 | -! | -
- all_ggplot2_args <- teal.widgets::resolve_ggplot2_args(- |
-
891 | -! | -
- user_plot = ggplot2_args[["Eigenvector plot"]],- |
-
892 | -! | -
- user_default = ggplot2_args$default,- |
-
893 | -! | -
- module_plot = dev_ggplot2_args- |
-
894 | -- |
- )- |
-
895 | -- | - - | -
896 | -! | -
- parsed_ggplot2_args <- teal.widgets::parse_ggplot2_args(- |
-
897 | -! | -
- all_ggplot2_args,- |
-
898 | -! | -
- ggtheme = ggtheme- |
-
899 | -- |
- )- |
-
900 | -- | - - | -
901 | -! | -
- ggplot_exprs <- c(- |
-
902 | -! | -
- list(- |
-
903 | -! | -
- quote(ggplot(pca_rot)),- |
-
904 | -! | -
- substitute(- |
-
905 | -! | -
- geom_bar(- |
-
906 | -! | -
- aes_string(x = "Variable", y = pc),- |
-
907 | -! | -
- stat = "identity",- |
-
908 | -! | -
- color = "black",- |
-
909 | -! | -
- fill = c(getOption("ggplot2.discrete.colour"), "lightblue")[1]- |
-
910 | -- |
- ),- |
-
911 | -! | -
- env = list(pc = pc)- |
-
912 | -- |
- ),- |
-
913 | -! | -
- substitute(- |
-
914 | -! | -
- geom_text(- |
-
915 | -! | -
- aes(- |
-
916 | -! | -
- x = Variable,- |
-
917 | -! | -
- y = pc_name,- |
-
918 | -! | -
- label = round(pc_name, 3),- |
-
919 | -! | -
- vjust = ifelse(pc_name > 0, -0.5, 1.3)- |
-
920 | -- |
- )- |
-
921 | -- |
- ),- |
-
922 | -! | -
- env = list(pc_name = as.name(pc))- |
-
923 | -- |
- )- |
-
924 | -- |
- ),- |
-
925 | -! | -
- parsed_ggplot2_args$labs,- |
-
926 | -! | -
- parsed_ggplot2_args$ggtheme,- |
-
927 | -! | -
- parsed_ggplot2_args$theme- |
-
928 | -- |
- )- |
-
929 | -- | - - | -
930 | -! | -
- teal.code::eval_code(- |
-
931 | -! | -
- base_q,- |
-
932 | -! | -
- substitute(- |
-
933 | -! | -
- expr = {- |
-
934 | -! | -
- pca_rot <- pca$rotation[, pc, drop = FALSE] %>%- |
-
935 | -! | -
- dplyr::as_tibble(rownames = "Variable")- |
-
936 | -- | - - | -
937 | -! | -
- g <- plot_call- |
-
938 | -- | - - | -
939 | -! | -
- print(g)- |
-
940 | -- |
- },- |
-
941 | -! | -
- env = list(- |
-
942 | -! | -
- pc = pc,- |
-
943 | -! | -
- plot_call = Reduce(function(x, y) call("+", x, y), ggplot_exprs)- |
-
944 | -- |
- )- |
-
945 | -- |
- )- |
-
946 | -- |
- )- |
-
947 | -- |
- }- |
-
948 | -- | - - | -
949 | -- |
- # plot final ----- |
-
950 | -! | -
- output_q <- reactive({- |
-
951 | -! | -
- req(computation())- |
-
952 | -! | -
- teal::validate_inputs(iv_r())- |
-
953 | -! | -
- teal::validate_inputs(iv_extra, header = "Plot settings are required")- |
-
954 | -- | - - | -
955 | -! | -
- switch(input$plot_type,- |
-
956 | -! | -
- "Elbow plot" = plot_elbow(computation()),- |
-
957 | -! | -
- "Circle plot" = plot_circle(computation()),- |
-
958 | -! | -
- "Biplot" = plot_biplot(computation()),- |
-
959 | -! | -
- "Eigenvector plot" = plot_pc_var(computation()),- |
-
960 | -! | -
- stop("Unknown plot")- |
-
961 | -- |
- )- |
-
962 | -- |
- })- |
-
963 | -- | - - | -
964 | -! | -
- plot_r <- reactive({- |
-
965 | -! | -
- output_q()[["g"]]- |
-
966 | -- |
- })- |
-
967 | -- | - - | -
968 | -! | -
- pws <- teal.widgets::plot_with_settings_srv(- |
-
969 | -! | -
- id = "pca_plot",- |
-
970 | -! | -
- plot_r = plot_r,- |
-
971 | -! | -
- height = plot_height,- |
-
972 | -! | -
- width = plot_width,- |
-
973 | -! | -
- graph_align = "center"- |
-
974 | -- |
- )- |
-
975 | -- | - - | -
976 | -- |
- # tables ----- |
-
977 | -! | -
- output$tbl_importance <- renderTable(- |
-
978 | -! | -
- expr = {- |
-
979 | -! | -
- req("importance" %in% input$tables_display, computation())- |
-
980 | -! | -
- computation()[["tbl_importance"]]- |
-
981 | -- |
- },- |
-
982 | -! | -
- bordered = TRUE,- |
-
983 | -! | -
- align = "c",- |
-
984 | -! | -
- digits = 3- |
-
985 | -- |
- )- |
-
986 | -- | - - | -
987 | -! | -
- output$tbl_importance_ui <- renderUI({- |
-
988 | -! | -
- req("importance" %in% input$tables_display)- |
-
989 | -! | -
- div(- |
-
990 | -! | -
- align = "center",- |
-
991 | -! | -
- tags$h4("Principal components importance"),- |
-
992 | -! | -
- tableOutput(session$ns("tbl_importance")),- |
-
993 | -! | -
- hr()- |
-
994 | -- |
- )- |
-
995 | -- |
- })- |
-
996 | -- | - - | -
997 | -! | -
- output$tbl_eigenvector <- renderTable(- |
-
998 | -! | -
- expr = {- |
-
999 | -! | -
- req("eigenvector" %in% input$tables_display, req(computation()))- |
-
1000 | -! | -
- computation()[["tbl_eigenvector"]]- |
-
1001 | -- |
- },- |
-
1002 | -! | -
- bordered = TRUE,- |
-
1003 | -! | -
- align = "c",- |
-
1004 | -! | -
- digits = 3- |
-
1005 | -- |
- )- |
-
1006 | -- | - - | -
1007 | -! | -
- output$tbl_eigenvector_ui <- renderUI({- |
-
1008 | -! | -
- req("eigenvector" %in% input$tables_display)- |
-
1009 | -! | -
- div(- |
-
1010 | -! | -
- align = "center",- |
-
1011 | -! | -
- tags$h4("Eigenvectors"),- |
-
1012 | -! | -
- tableOutput(session$ns("tbl_eigenvector")),- |
-
1013 | -! | -
- hr()- |
-
1014 | -- |
- )- |
-
1015 | -- |
- })- |
-
1016 | -- | - - | -
1017 | -! | -
- output$all_plots <- renderUI({- |
-
1018 | -! | -
- teal::validate_inputs(iv_r())- |
-
1019 | -! | -
- teal::validate_inputs(iv_extra, header = "Plot settings are required")- |
-
1020 | -- | - - | -
1021 | -! | -
- validation()- |
-
1022 | -! | -
- tags$div(- |
-
1023 | -! | -
- class = "overflow-scroll",- |
-
1024 | -! | -
- uiOutput(session$ns("tbl_importance_ui")),- |
-
1025 | -! | -
- uiOutput(session$ns("tbl_eigenvector_ui")),- |
-
1026 | -! | -
- teal.widgets::plot_with_settings_ui(id = session$ns("pca_plot"))- |
-
1027 | -- |
- )- |
-
1028 | -- |
- })- |
-
1029 | -- | - - | -
1030 | -! | -
- teal.widgets::verbatim_popup_srv(- |
-
1031 | -! | -
- id = "warning",- |
-
1032 | -! | -
- verbatim_content = reactive(teal.code::get_warnings(output_q())),- |
-
1033 | -! | -
- title = "Warning",- |
-
1034 | -! | -
- disabled = reactive(is.null(teal.code::get_warnings(output_q())))- |
-
1035 | -- |
- )- |
-
1036 | -- | - - | -
1037 | -! | -
- teal.widgets::verbatim_popup_srv(- |
-
1038 | -! | -
- id = "rcode",- |
-
1039 | -! | -
- verbatim_content = reactive(teal.code::get_code(output_q())),- |
-
1040 | -! | -
- title = "R Code for PCA"- |
-
1041 | -- |
- )- |
-
1042 | -- | - - | -
1043 | -- |
- ### REPORTER- |
-
1044 | -! | -
- if (with_reporter) {- |
-
1045 | -! | -
- card_fun <- function(comment, label) {- |
-
1046 | -! | -
- card <- teal::report_card_template(- |
-
1047 | -! | -
- title = "Principal Component Analysis Plot",- |
-
1048 | -! | -
- label = label,- |
-
1049 | -! | -
- with_filter = with_filter,- |
-
1050 | -! | -
- filter_panel_api = filter_panel_api- |
-
1051 | -- |
- )- |
-
1052 | -! | -
- card$append_text("Principal Components Table", "header3")- |
-
1053 | -! | -
- card$append_table(computation()[["tbl_importance"]])- |
-
1054 | -! | -
- card$append_text("Eigenvectors Table", "header3")- |
-
1055 | -! | -
- card$append_table(computation()[["tbl_eigenvector"]])- |
-
1056 | -! | -
- card$append_text("Plot", "header3")- |
-
1057 | -! | -
- card$append_plot(plot_r(), dim = pws$dim())- |
-
1058 | -! | -
- if (!comment == "") {- |
-
1059 | -! | -
- card$append_text("Comment", "header3")- |
-
1060 | -! | -
- card$append_text(comment)- |
-
1061 | -- |
- }- |
-
1062 | -! | -
- card$append_src(teal.code::get_code(output_q()))- |
-
1063 | -! | -
- card- |
-
1064 | -- |
- }- |
-
1065 | -! | -
- teal.reporter::simple_reporter_srv("simple_reporter", reporter = reporter, card_fun = card_fun)- |
-
1066 | -- |
- }- |
-
1067 | -- |
- ###- |
-
1068 | -- |
- })- |
-
1069 | -- |
- }- |
-
1 | -- |
- #' `teal` module: Scatterplot- |
-
2 | -- |
- #'- |
-
3 | -- |
- #' Generates a customizable scatterplot using `ggplot2`.- |
-
4 | -- |
- #' This module allows users to select variables for the x and y axes,- |
-
5 | -- |
- #' color and size encodings, faceting options, and more. It supports log transformations,- |
-
6 | -- |
- #' trend line additions, and dynamic adjustments of point opacity and size through UI controls.- |
-
7 | -- |
- #'- |
-
8 | -- |
- #' @note For more examples, please see the vignette "Using scatterplot" via- |
-
9 | -- |
- #' `vignette("using-scatterplot", package = "teal.modules.general")`.- |
-
10 | -- |
- #'- |
-
11 | -- |
- #' @inheritParams teal::module- |
-
12 | -- |
- #' @inheritParams shared_params- |
-
13 | -- |
- #' @param x (`data_extract_spec` or `list` of multiple `data_extract_spec`) Specifies- |
-
14 | -- |
- #' variable names selected to plot along the x-axis by default.- |
-
15 | -- |
- #' @param y (`data_extract_spec` or `list` of multiple `data_extract_spec`) Specifies- |
-
16 | -- |
- #' variable names selected to plot along the y-axis by default.- |
-
17 | -- |
- #' @param color_by (`data_extract_spec` or `list` of multiple `data_extract_spec`) optional,- |
-
18 | -- |
- #' defines the color encoding. If `NULL` then no color encoding option will be displayed.- |
-
19 | -- |
- #' @param size_by (`data_extract_spec` or `list` of multiple `data_extract_spec`) optional,- |
-
20 | -- |
- #' defines the point size encoding. If `NULL` then no size encoding option will be displayed.- |
-
21 | -- |
- #' @param row_facet (`data_extract_spec` or `list` of multiple `data_extract_spec`) optional,- |
-
22 | -- |
- #' specifies the variable(s) for faceting rows.- |
-
23 | -- |
- #' @param col_facet (`data_extract_spec` or `list` of multiple `data_extract_spec`) optional,- |
-
24 | -- |
- #' specifies the variable(s) for faceting columns.- |
-
25 | -- |
- #' @param shape (`character`) optional, character vector with the names of the- |
-
26 | -- |
- #' shape, e.g. `c("triangle", "square", "circle")`. It defaults to `shape_names`. This is a complete list from- |
-
27 | -- |
- #' `vignette("ggplot2-specs", package="ggplot2")`.- |
-
28 | -- |
- #' @param max_deg (`integer`) optional, maximum degree for the polynomial trend line. Must not be less than 1.- |
-
29 | -- |
- #' @param table_dec (`integer`) optional, number of decimal places used to round numeric values in the table.- |
-
30 | -- |
- #'- |
-
31 | -- |
- #' @inherit shared_params return- |
-
32 | -- |
- #'- |
-
33 | -- |
- #' @examples- |
-
34 | -- |
- #' library(teal.widgets)- |
-
35 | -- |
- #'- |
-
36 | -- |
- #' # general data example- |
-
37 | -- |
- #' data <- teal_data()- |
-
38 | -- |
- #' data <- within(data, {- |
-
39 | -- |
- #' require(nestcolor)- |
-
40 | -- |
- #' CO2 <- CO2- |
-
41 | -- |
- #' })- |
-
42 | -- |
- #' datanames(data) <- "CO2"- |
-
43 | -- |
- #'- |
-
44 | -- |
- #' app <- init(- |
-
45 | -- |
- #' data = data,- |
-
46 | -- |
- #' modules = modules(- |
-
47 | -- |
- #' tm_g_scatterplot(- |
-
48 | -- |
- #' label = "Scatterplot Choices",- |
-
49 | -- |
- #' x = data_extract_spec(- |
-
50 | -- |
- #' dataname = "CO2",- |
-
51 | -- |
- #' select = select_spec(- |
-
52 | -- |
- #' label = "Select variable:",- |
-
53 | -- |
- #' choices = variable_choices(data[["CO2"]], c("conc", "uptake")),- |
-
54 | -- |
- #' selected = "conc",- |
-
55 | -- |
- #' multiple = FALSE,- |
-
56 | -- |
- #' fixed = FALSE- |
-
57 | -- |
- #' )- |
-
58 | -- |
- #' ),- |
-
59 | -- |
- #' y = data_extract_spec(- |
-
60 | -- |
- #' dataname = "CO2",- |
-
61 | -- |
- #' select = select_spec(- |
-
62 | -- |
- #' label = "Select variable:",- |
-
63 | -- |
- #' choices = variable_choices(data[["CO2"]], c("conc", "uptake")),- |
-
64 | -- |
- #' selected = "uptake",- |
-
65 | -- |
- #' multiple = FALSE,- |
-
66 | -- |
- #' fixed = FALSE- |
-
67 | -- |
- #' )- |
-
68 | -- |
- #' ),- |
-
69 | -- |
- #' color_by = data_extract_spec(- |
-
70 | -- |
- #' dataname = "CO2",- |
-
71 | -- |
- #' select = select_spec(- |
-
72 | -- |
- #' label = "Select variable:",- |
-
73 | -- |
- #' choices = variable_choices(- |
-
74 | -- |
- #' data[["CO2"]],- |
-
75 | -- |
- #' c("Plant", "Type", "Treatment", "conc", "uptake")- |
-
76 | -- |
- #' ),- |
-
77 | -- |
- #' selected = NULL,- |
-
78 | -- |
- #' multiple = FALSE,- |
-
79 | -- |
- #' fixed = FALSE- |
-
80 | -- |
- #' )- |
-
81 | -- |
- #' ),- |
-
82 | -- |
- #' size_by = data_extract_spec(- |
-
83 | -- |
- #' dataname = "CO2",- |
-
84 | -- |
- #' select = select_spec(- |
-
85 | -- |
- #' label = "Select variable:",- |
-
86 | -- |
- #' choices = variable_choices(data[["CO2"]], c("conc", "uptake")),- |
-
87 | -- |
- #' selected = "uptake",- |
-
88 | -- |
- #' multiple = FALSE,- |
-
89 | -- |
- #' fixed = FALSE- |
-
90 | -- |
- #' )- |
-
91 | -- |
- #' ),- |
-
92 | -- |
- #' row_facet = data_extract_spec(- |
-
93 | -- |
- #' dataname = "CO2",- |
-
94 | -- |
- #' select = select_spec(- |
-
95 | -- |
- #' label = "Select variable:",- |
-
96 | -- |
- #' choices = variable_choices(data[["CO2"]], c("Plant", "Type", "Treatment")),- |
-
97 | -- |
- #' selected = NULL,- |
-
98 | -- |
- #' multiple = FALSE,- |
-
99 | -- |
- #' fixed = FALSE- |
-
100 | -- |
- #' )- |
-
101 | -- |
- #' ),- |
-
102 | -- |
- #' col_facet = data_extract_spec(- |
-
103 | -- |
- #' dataname = "CO2",- |
-
104 | -- |
- #' select = select_spec(- |
-
105 | -- |
- #' label = "Select variable:",- |
-
106 | -- |
- #' choices = variable_choices(data[["CO2"]], c("Plant", "Type", "Treatment")),- |
-
107 | -- |
- #' selected = NULL,- |
-
108 | -- |
- #' multiple = FALSE,- |
-
109 | -- |
- #' fixed = FALSE- |
-
110 | -- |
- #' )- |
-
111 | -- |
- #' ),- |
-
112 | -- |
- #' ggplot2_args = ggplot2_args(- |
-
113 | -- |
- #' labs = list(subtitle = "Plot generated by Scatterplot Module")- |
-
114 | -- |
- #' )- |
-
115 | -- |
- #' )- |
-
116 | -- |
- #' )- |
-
117 | -- |
- #' )- |
-
118 | -- |
- #' if (interactive()) {- |
-
119 | -- |
- #' shinyApp(app$ui, app$server)- |
-
120 | -- |
- #' }- |
-
121 | -- |
- #'- |
-
122 | -- |
- #' # CDISC data example- |
-
123 | -- |
- #' data <- teal_data()- |
-
124 | -- |
- #' data <- within(data, {- |
-
125 | -- |
- #' require(nestcolor)- |
-
126 | -- |
- #' ADSL <- rADSL- |
-
127 | -- |
- #' })- |
-
128 | -- |
- #' datanames(data) <- c("ADSL")- |
-
129 | -- |
- #' join_keys(data) <- default_cdisc_join_keys[datanames(data)]- |
-
130 | -- |
- #'- |
-
131 | -- |
- #' app <- init(- |
-
132 | -- |
- #' data = data,- |
-
133 | -- |
- #' modules = modules(- |
-
134 | -- |
- #' tm_g_scatterplot(- |
-
135 | -- |
- #' label = "Scatterplot Choices",- |
-
136 | -- |
- #' x = data_extract_spec(- |
-
137 | -- |
- #' dataname = "ADSL",- |
-
138 | -- |
- #' select = select_spec(- |
-
139 | -- |
- #' label = "Select variable:",- |
-
140 | -- |
- #' choices = variable_choices(data[["ADSL"]], c("AGE", "BMRKR1", "BMRKR2")),- |
-
141 | -- |
- #' selected = "AGE",- |
-
142 | -- |
- #' multiple = FALSE,- |
-
143 | -- |
- #' fixed = FALSE- |
-
144 | -- |
- #' )- |
-
145 | -- |
- #' ),- |
-
146 | -- |
- #' y = data_extract_spec(- |
-
147 | -- |
- #' dataname = "ADSL",- |
-
148 | -- |
- #' select = select_spec(- |
-
149 | -- |
- #' label = "Select variable:",- |
-
150 | -- |
- #' choices = variable_choices(data[["ADSL"]], c("AGE", "BMRKR1", "BMRKR2")),- |
-
151 | -- |
- #' selected = "BMRKR1",- |
-
152 | -- |
- #' multiple = FALSE,- |
-
153 | -- |
- #' fixed = FALSE- |
-
154 | -- |
- #' )- |
-
155 | -- |
- #' ),- |
-
156 | -- |
- #' color_by = data_extract_spec(- |
-
157 | -- |
- #' dataname = "ADSL",- |
-
158 | -- |
- #' select = select_spec(- |
-
159 | -- |
- #' label = "Select variable:",- |
-
160 | -- |
- #' choices = variable_choices(- |
-
161 | -- |
- #' data[["ADSL"]],- |
-
162 | -- |
- #' c("AGE", "BMRKR1", "BMRKR2", "RACE", "REGION1")- |
-
163 | -- |
- #' ),- |
-
164 | -- |
- #' selected = NULL,- |
-
165 | -- |
- #' multiple = FALSE,- |
-
166 | -- |
- #' fixed = FALSE- |
-
167 | -- |
- #' )- |
-
168 | -- |
- #' ),- |
-
169 | -- |
- #' size_by = data_extract_spec(- |
-
170 | -- |
- #' dataname = "ADSL",- |
-
171 | -- |
- #' select = select_spec(- |
-
172 | -- |
- #' label = "Select variable:",- |
-
173 | -- |
- #' choices = variable_choices(data[["ADSL"]], c("AGE", "BMRKR1")),- |
-
174 | -- |
- #' selected = "AGE",- |
-
175 | -- |
- #' multiple = FALSE,- |
-
176 | -- |
- #' fixed = FALSE- |
-
177 | -- |
- #' )- |
-
178 | -- |
- #' ),- |
-
179 | -- |
- #' row_facet = data_extract_spec(- |
-
180 | -- |
- #' dataname = "ADSL",- |
-
181 | -- |
- #' select = select_spec(- |
-
182 | -- |
- #' label = "Select variable:",- |
-
183 | -- |
- #' choices = variable_choices(data[["ADSL"]], c("BMRKR2", "RACE", "REGION1")),- |
-
184 | -- |
- #' selected = NULL,- |
-
185 | -- |
- #' multiple = FALSE,- |
-
186 | -- |
- #' fixed = FALSE- |
-
187 | -- |
- #' )- |
-
188 | -- |
- #' ),- |
-
189 | -- |
- #' col_facet = data_extract_spec(- |
-
190 | -- |
- #' dataname = "ADSL",- |
-
191 | -- |
- #' select = select_spec(- |
-
192 | -- |
- #' label = "Select variable:",- |
-
193 | -- |
- #' choices = variable_choices(data[["ADSL"]], c("BMRKR2", "RACE", "REGION1")),- |
-
194 | -- |
- #' selected = NULL,- |
-
195 | -- |
- #' multiple = FALSE,- |
-
196 | -- |
- #' fixed = FALSE- |
-
197 | -- |
- #' )- |
-
198 | -- |
- #' ),- |
-
199 | -- |
- #' ggplot2_args = ggplot2_args(- |
-
200 | -- |
- #' labs = list(subtitle = "Plot generated by Scatterplot Module")- |
-
201 | -- |
- #' )- |
-
202 | -- |
- #' )- |
-
203 | -- |
- #' )- |
-
204 | -- |
- #' )- |
-
205 | -- |
- #' if (interactive()) {- |
-
206 | -- |
- #' shinyApp(app$ui, app$server)- |
-
207 | -- |
- #' }- |
-
208 | -- |
- #'- |
-
209 | -- |
- #' @export- |
-
210 | -- |
- #'- |
-
211 | -- |
- tm_g_scatterplot <- function(label = "Scatterplot",- |
-
212 | -- |
- x,- |
-
213 | -- |
- y,- |
-
214 | -- |
- color_by = NULL,- |
-
215 | -- |
- size_by = NULL,- |
-
216 | -- |
- row_facet = NULL,- |
-
217 | -- |
- col_facet = NULL,- |
-
218 | -- |
- plot_height = c(600, 200, 2000),- |
-
219 | -- |
- plot_width = NULL,- |
-
220 | -- |
- alpha = c(1, 0, 1),- |
-
221 | -- |
- shape = shape_names,- |
-
222 | -- |
- size = c(5, 1, 15),- |
-
223 | -- |
- max_deg = 5L,- |
-
224 | -- |
- rotate_xaxis_labels = FALSE,- |
-
225 | -- |
- ggtheme = c("gray", "bw", "linedraw", "light", "dark", "minimal", "classic", "void"),- |
-
226 | -- |
- pre_output = NULL,- |
-
227 | -- |
- post_output = NULL,- |
-
228 | -- |
- table_dec = 4,- |
-
229 | -- |
- ggplot2_args = teal.widgets::ggplot2_args()) {- |
-
230 | -! | -
- logger::log_info("Initializing tm_g_scatterplot")- |
-
231 | -- | - - | -
232 | -- |
- # Requires Suggested packages- |
-
233 | -! | -
- extra_packages <- c("ggpmisc", "ggExtra", "colourpicker")- |
-
234 | -! | -
- missing_packages <- Filter(function(x) !requireNamespace(x, quietly = TRUE), extra_packages)- |
-
235 | -! | -
- if (length(missing_packages) > 0L) {- |
-
236 | -! | -
- stop(sprintf(- |
-
237 | -! | -
- "Cannot load package(s): %s.\nInstall or restart your session.",- |
-
238 | -! | -
- toString(missing_packages)- |
-
239 | -- |
- ))- |
-
240 | -- |
- }- |
-
241 | -- | - - | -
242 | -- |
- # Normalize the parameters- |
-
243 | -! | -
- if (inherits(x, "data_extract_spec")) x <- list(x)- |
-
244 | -! | -
- if (inherits(y, "data_extract_spec")) y <- list(y)- |
-
245 | -! | -
- if (inherits(color_by, "data_extract_spec")) color_by <- list(color_by)- |
-
246 | -! | -
- if (inherits(size_by, "data_extract_spec")) size_by <- list(size_by)- |
-
247 | -! | -
- if (inherits(row_facet, "data_extract_spec")) row_facet <- list(row_facet)- |
-
248 | -! | -
- if (inherits(col_facet, "data_extract_spec")) col_facet <- list(col_facet)- |
-
249 | -! | -
- if (is.double(max_deg)) max_deg <- as.integer(max_deg)- |
-
250 | -- | - - | -
251 | -- |
- # Start of assertions- |
-
252 | -! | -
- checkmate::assert_string(label)- |
-
253 | -! | -
- checkmate::assert_list(x, types = "data_extract_spec")- |
-
254 | -! | -
- checkmate::assert_list(y, types = "data_extract_spec")- |
-
255 | -! | -
- checkmate::assert_list(color_by, types = "data_extract_spec", null.ok = TRUE)- |
-
256 | -! | -
- checkmate::assert_list(size_by, types = "data_extract_spec", null.ok = TRUE)- |
-
257 | -- | - - | -
258 | -! | -
- checkmate::assert_list(row_facet, types = "data_extract_spec", null.ok = TRUE)- |
-
259 | -! | -
- assert_single_selection(row_facet)- |
-
260 | -- | - - | -
261 | -! | -
- checkmate::assert_list(col_facet, types = "data_extract_spec", null.ok = TRUE)- |
-
262 | -! | -
- assert_single_selection(col_facet)- |
-
263 | -- | - - | -
264 | -! | -
- checkmate::assert_numeric(plot_height, len = 3, any.missing = FALSE, finite = TRUE)- |
-
265 | -! | -
- checkmate::assert_numeric(plot_height[1], lower = plot_height[2], upper = plot_height[3], .var.name = "plot_height")- |
-
266 | -! | -
- checkmate::assert_numeric(plot_width, len = 3, any.missing = FALSE, null.ok = TRUE, finite = TRUE)- |
-
267 | -! | -
- checkmate::assert_numeric(- |
-
268 | -! | -
- plot_width[1],- |
-
269 | -! | -
- lower = plot_width[2], upper = plot_width[3], null.ok = TRUE, .var.name = "plot_width"- |
-
270 | -- |
- )- |
-
271 | -- | - - | -
272 | -! | -
- if (length(alpha) == 1) {- |
-
273 | -! | -
- checkmate::assert_numeric(alpha, any.missing = FALSE, finite = TRUE)- |
-
274 | -- |
- } else {- |
-
275 | -! | -
- checkmate::assert_numeric(alpha, len = 3, any.missing = FALSE, finite = TRUE)- |
-
276 | -! | -
- checkmate::assert_numeric(alpha[1], lower = alpha[2], upper = alpha[3], .var.name = "alpha")- |
-
277 | -- |
- }- |
-
278 | -- | - - | -
279 | -! | -
- checkmate::assert_character(shape)- |
-
280 | -- | - - | -
281 | -! | -
- if (length(size) == 1) {- |
-
282 | -! | -
- checkmate::assert_numeric(size, any.missing = FALSE, finite = TRUE)- |
-
283 | -- |
- } else {- |
-
284 | -! | -
- checkmate::assert_numeric(size, len = 3, any.missing = FALSE, finite = TRUE)- |
-
285 | -! | -
- checkmate::assert_numeric(size[1], lower = size[2], upper = size[3], .var.name = "size")- |
-
286 | -- |
- }- |
-
287 | -- | - - | -
288 | -! | -
- checkmate::assert_int(max_deg, lower = 1L)- |
-
289 | -! | -
- checkmate::assert_flag(rotate_xaxis_labels)- |
-
290 | -! | -
- ggtheme <- match.arg(ggtheme)- |
-
291 | -- | - - | -
292 | -! | -
- checkmate::assert_multi_class(pre_output, c("shiny.tag", "shiny.tag.list", "html"), null.ok = TRUE)- |
-
293 | -! | -
- checkmate::assert_multi_class(post_output, c("shiny.tag", "shiny.tag.list", "html"), null.ok = TRUE)- |
-
294 | -- | - - | -
295 | -! | -
- checkmate::assert_scalar(table_dec)- |
-
296 | -! | -
- checkmate::assert_class(ggplot2_args, "ggplot2_args")- |
-
297 | -- |
- # End of assertions- |
-
298 | -- | - - | -
299 | -- |
- # Make UI args- |
-
300 | -! | -
- args <- as.list(environment())- |
-
301 | -- | - - | -
302 | -! | -
- data_extract_list <- list(- |
-
303 | -! | -
- x = x,- |
-
304 | -! | -
- y = y,- |
-
305 | -! | -
- color_by = color_by,- |
-
306 | -! | -
- size_by = size_by,- |
-
307 | -! | -
- row_facet = row_facet,- |
-
308 | -! | -
- col_facet = col_facet- |
-
309 | -- |
- )- |
-
310 | -- | - - | -
311 | -! | -
- module(- |
-
312 | -! | -
- label = label,- |
-
313 | -! | -
- server = srv_g_scatterplot,- |
-
314 | -! | -
- ui = ui_g_scatterplot,- |
-
315 | -! | -
- ui_args = args,- |
-
316 | -! | -
- server_args = c(- |
-
317 | -! | -
- data_extract_list,- |
-
318 | -! | -
- list(plot_height = plot_height, plot_width = plot_width, table_dec = table_dec, ggplot2_args = ggplot2_args)- |
-
319 | -- |
- ),- |
-
320 | -! | -
- datanames = teal.transform::get_extract_datanames(data_extract_list)- |
-
321 | -- |
- )- |
-
322 | -- |
- }- |
-
323 | -- | - - | -
324 | -- |
- # UI function for the scatterplot module- |
-
325 | -- |
- ui_g_scatterplot <- function(id, ...) {- |
-
326 | -! | -
- args <- list(...)- |
-
327 | -! | -
- ns <- NS(id)- |
-
328 | -! | -
- is_single_dataset_value <- teal.transform::is_single_dataset(- |
-
329 | -! | -
- args$x, args$y, args$color_by, args$size_by, args$row_facet, args$col_facet- |
-
330 | -- |
- )- |
-
331 | -- | - - | -
332 | -! | -
- shiny::tagList(- |
-
333 | -! | -
- include_css_files("custom"),- |
-
334 | -! | -
- teal.widgets::standard_layout(- |
-
335 | -! | -
- output = teal.widgets::white_small_well(- |
-
336 | -! | -
- teal.widgets::plot_with_settings_ui(id = ns("scatter_plot")),- |
-
337 | -! | -
- tags$h1(tags$strong("Selected points:"), class = "text-center font-150p"),- |
-
338 | -! | -
- teal.widgets::get_dt_rows(ns("data_table"), ns("data_table_rows")),- |
-
339 | -! | -
- DT::dataTableOutput(ns("data_table"), width = "100%")- |
-
340 | -- |
- ),- |
-
341 | -! | -
- encoding = div(- |
-
342 | -- |
- ### Reporter- |
-
343 | -! | -
- teal.reporter::simple_reporter_ui(ns("simple_reporter")),- |
-
344 | -- |
- ###- |
-
345 | -! | -
- tags$label("Encodings", class = "text-primary"),- |
-
346 | -! | -
- teal.transform::datanames_input(args[c("x", "y", "color_by", "size_by", "row_facet", "col_facet")]),- |
-
347 | -! | -
- teal.transform::data_extract_ui(- |
-
348 | -! | -
- id = ns("x"),- |
-
349 | -! | -
- label = "X variable",- |
-
350 | -! | -
- data_extract_spec = args$x,- |
-
351 | -! | -
- is_single_dataset = is_single_dataset_value- |
-
352 | -- |
- ),- |
-
353 | -! | -
- checkboxInput(ns("log_x"), "Use log transformation", value = FALSE),- |
-
354 | -! | -
- conditionalPanel(- |
-
355 | -! | -
- condition = paste0("input['", ns("log_x"), "'] == true"),- |
-
356 | -! | -
- radioButtons(- |
-
357 | -! | -
- ns("log_x_base"),- |
-
358 | -! | -
- label = NULL,- |
-
359 | -! | -
- inline = TRUE,- |
-
360 | -! | -
- choices = c("Natural" = "log", "Base 10" = "log10", "Base 2" = "log2")- |
-
361 | -- |
- )- |
-
362 | -- |
- ),- |
-
363 | -! | -
- teal.transform::data_extract_ui(- |
-
364 | -! | -
- id = ns("y"),- |
-
365 | -! | -
- label = "Y variable",- |
-
366 | -! | -
- data_extract_spec = args$y,- |
-
367 | -! | -
- is_single_dataset = is_single_dataset_value- |
-
368 | -- |
- ),- |
-
369 | -! | -
- checkboxInput(ns("log_y"), "Use log transformation", value = FALSE),- |
-
370 | -! | -
- conditionalPanel(- |
-
371 | -! | -
- condition = paste0("input['", ns("log_y"), "'] == true"),- |
-
372 | -! | -
- radioButtons(- |
-
373 | -! | -
- ns("log_y_base"),- |
-
374 | -! | -
- label = NULL,- |
-
375 | -! | -
- inline = TRUE,- |
-
376 | -! | -
- choices = c("Natural" = "log", "Base 10" = "log10", "Base 2" = "log2")- |
-
377 | -- |
- )- |
-
378 | -- |
- ),- |
-
379 | -! | -
- if (!is.null(args$color_by)) {- |
-
380 | -! | -
- teal.transform::data_extract_ui(- |
-
381 | -! | -
- id = ns("color_by"),- |
-
382 | -! | -
- label = "Color by variable",- |
-
383 | -! | -
- data_extract_spec = args$color_by,- |
-
384 | -! | -
- is_single_dataset = is_single_dataset_value- |
-
385 | -- |
- )- |
-
386 | -- |
- },- |
-
387 | -! | -
- if (!is.null(args$size_by)) {- |
-
388 | -! | -
- teal.transform::data_extract_ui(- |
-
389 | -! | -
- id = ns("size_by"),- |
-
390 | -! | -
- label = "Size by variable",- |
-
391 | -! | -
- data_extract_spec = args$size_by,- |
-
392 | -! | -
- is_single_dataset = is_single_dataset_value- |
-
393 | -- |
- )- |
-
394 | -- |
- },- |
-
395 | -! | -
- if (!is.null(args$row_facet)) {- |
-
396 | -! | -
- teal.transform::data_extract_ui(- |
-
397 | -! | -
- id = ns("row_facet"),- |
-
398 | -! | -
- label = "Row facetting",- |
-
399 | -! | -
- data_extract_spec = args$row_facet,- |
-
400 | -! | -
- is_single_dataset = is_single_dataset_value- |
-
401 | -- |
- )- |
-
402 | -- |
- },- |
-
403 | -! | -
- if (!is.null(args$col_facet)) {- |
-
404 | -! | -
- teal.transform::data_extract_ui(- |
-
405 | -! | -
- id = ns("col_facet"),- |
-
406 | -! | -
- label = "Column facetting",- |
-
407 | -! | -
- data_extract_spec = args$col_facet,- |
-
408 | -! | -
- is_single_dataset = is_single_dataset_value- |
-
409 | -- |
- )- |
-
410 | -- |
- },- |
-
411 | -! | -
- teal.widgets::panel_group(- |
-
412 | -! | -
- teal.widgets::panel_item(- |
-
413 | -! | -
- title = "Plot settings",- |
-
414 | -! | -
- teal.widgets::optionalSliderInputValMinMax(ns("alpha"), "Opacity:", args$alpha, ticks = FALSE),- |
-
415 | -! | -
- teal.widgets::optionalSelectInput(- |
-
416 | -! | -
- inputId = ns("shape"),- |
-
417 | -! | -
- label = "Points shape:",- |
-
418 | -! | -
- choices = args$shape,- |
-
419 | -! | -
- selected = args$shape[1],- |
-
420 | -! | -
- multiple = FALSE- |
-
421 | -- |
- ),- |
-
422 | -! | -
- colourpicker::colourInput(ns("color"), "Points color:", "black"),- |
-
423 | -! | -
- teal.widgets::optionalSliderInputValMinMax(ns("size"), "Points size:", args$size, ticks = FALSE, step = .1),- |
-
424 | -! | -
- checkboxInput(ns("rotate_xaxis_labels"), "Rotate X axis labels", value = args$rotate_xaxis_labels),- |
-
425 | -! | -
- checkboxInput(ns("add_density"), "Add marginal density", value = FALSE),- |
-
426 | -! | -
- checkboxInput(ns("rug_plot"), "Include rug plot", value = FALSE),- |
-
427 | -! | -
- checkboxInput(ns("show_count"), "Show N (number of observations)", value = FALSE),- |
-
428 | -! | -
- shinyjs::hidden(helpText(id = ns("line_msg"), "Trendline needs numeric X and Y variables")),- |
-
429 | -! | -
- teal.widgets::optionalSelectInput(ns("smoothing_degree"), "Smoothing degree", seq_len(args$max_deg)),- |
-
430 | -! | -
- shinyjs::hidden(teal.widgets::optionalSelectInput(ns("color_sub"), label = "", multiple = TRUE)),- |
-
431 | -! | -
- teal.widgets::optionalSliderInputValMinMax(ns("ci"), "Confidence", c(.95, .8, .99), ticks = FALSE),- |
-
432 | -! | -
- shinyjs::hidden(checkboxInput(ns("show_form"), "Show formula", value = TRUE)),- |
-
433 | -! | -
- shinyjs::hidden(checkboxInput(ns("show_r2"), "Show adj-R Squared", value = TRUE)),- |
-
434 | -! | -
- uiOutput(ns("num_na_removed")),- |
-
435 | -! | -
- div(- |
-
436 | -! | -
- id = ns("label_pos"),- |
-
437 | -! | -
- div(strong("Stats position")),- |
-
438 | -! | -
- div(class = "inline-block w-10", helpText("Left")),- |
-
439 | -! | -
- div(- |
-
440 | -! | -
- class = "inline-block w-70",- |
-
441 | -! | -
- teal.widgets::optionalSliderInput(- |
-
442 | -! | -
- ns("pos"),- |
-
443 | -! | -
- label = NULL,- |
-
444 | -! | -
- min = 0, max = 1, value = .99, ticks = FALSE, step = .01- |
-
445 | -- |
- )- |
-
446 | -- |
- ),- |
-
447 | -! | -
- div(class = "inline-block w-10", helpText("Right"))- |
-
448 | -- |
- ),- |
-
449 | -! | -
- teal.widgets::optionalSliderInput(- |
-
450 | -! | -
- ns("label_size"), "Stats font size",- |
-
451 | -! | -
- min = 3, max = 10, value = 5, ticks = FALSE, step = .1- |
-
452 | -- |
- ),- |
-
453 | -! | -
- if (!is.null(args$row_facet) || !is.null(args$col_facet)) {- |
-
454 | -! | -
- checkboxInput(ns("free_scales"), "Free scales", value = FALSE)- |
-
455 | -- |
- },- |
-
456 | -! | -
- selectInput(- |
-
457 | -! | -
- inputId = ns("ggtheme"),- |
-
458 | -! | -
- label = "Theme (by ggplot):",- |
-
459 | -! | -
- choices = ggplot_themes,- |
-
460 | -! | -
- selected = args$ggtheme,- |
-
461 | -! | -
- multiple = FALSE- |
-
462 | -- |
- )- |
-
463 | -- |
- )- |
-
464 | -- |
- )- |
-
465 | -- |
- ),- |
-
466 | -! | -
- forms = tagList(- |
-
467 | -! | -
- teal.widgets::verbatim_popup_ui(ns("warning"), button_label = "Show Warnings"),- |
-
468 | -! | -
- teal.widgets::verbatim_popup_ui(ns("rcode"), "Show R code")- |
-
469 | -- |
- ),- |
-
470 | -! | -
- pre_output = args$pre_output,- |
-
471 | -! | -
- post_output = args$post_output- |
-
472 | -- |
- )- |
-
473 | -- |
- )- |
-
474 | -- |
- }- |
-
475 | -- | - - | -
476 | -- |
- # Server function for the scatterplot module- |
-
477 | -- |
- srv_g_scatterplot <- function(id,- |
-
478 | -- |
- data,- |
-
479 | -- |
- reporter,- |
-
480 | -- |
- filter_panel_api,- |
-
481 | -- |
- x,- |
-
482 | -- |
- y,- |
-
483 | -- |
- color_by,- |
-
484 | -- |
- size_by,- |
-
485 | -- |
- row_facet,- |
-
486 | -- |
- col_facet,- |
-
487 | -- |
- plot_height,- |
-
488 | -- |
- plot_width,- |
-
489 | -- |
- table_dec,- |
-
490 | -- |
- ggplot2_args) {- |
-
491 | -! | -
- with_reporter <- !missing(reporter) && inherits(reporter, "Reporter")- |
-
492 | -! | -
- with_filter <- !missing(filter_panel_api) && inherits(filter_panel_api, "FilterPanelAPI")- |
-
493 | -! | -
- checkmate::assert_class(data, "reactive")- |
-
494 | -! | -
- checkmate::assert_class(isolate(data()), "teal_data")- |
-
495 | -! | -
- moduleServer(id, function(input, output, session) {- |
-
496 | -! | -
- data_extract <- list(- |
-
497 | -! | -
- x = x,- |
-
498 | -! | -
- y = y,- |
-
499 | -! | -
- color_by = color_by,- |
-
500 | -! | -
- size_by = size_by,- |
-
501 | -! | -
- row_facet = row_facet,- |
-
502 | -! | -
- col_facet = col_facet- |
-
503 | -- |
- )- |
-
504 | -- | - - | -
505 | -! | -
- rule_diff <- function(other) {- |
-
506 | -! | -
- function(value) {- |
-
507 | -! | -
- othervalue <- selector_list()[[other]]()[["select"]]- |
-
508 | -! | -
- if (!is.null(othervalue)) {- |
-
509 | -! | -
- if (identical(value, othervalue)) {- |
-
510 | -! | -
- "Row and column facetting variables must be different."- |
-
511 | -- |
- }- |
-
512 | -- |
- }- |
-
513 | -- |
- }- |
-
514 | -- |
- }- |
-
515 | -- | - - | -
516 | -! | -
- selector_list <- teal.transform::data_extract_multiple_srv(- |
-
517 | -! | -
- data_extract = data_extract,- |
-
518 | -! | -
- datasets = data,- |
-
519 | -! | -
- select_validation_rule = list(- |
-
520 | -! | -
- x = ~ if (length(.) != 1) "Please select exactly one x var.",- |
-
521 | -! | -
- y = ~ if (length(.) != 1) "Please select exactly one y var.",- |
-
522 | -! | -
- color_by = ~ if (length(.) > 1) "There cannot be more than 1 color variable.",- |
-
523 | -! | -
- size_by = ~ if (length(.) > 1) "There cannot be more than 1 size variable.",- |
-
524 | -! | -
- row_facet = shinyvalidate::compose_rules(- |
-
525 | -! | -
- shinyvalidate::sv_optional(),- |
-
526 | -! | -
- rule_diff("col_facet")- |
-
527 | -- |
- ),- |
-
528 | -! | -
- col_facet = shinyvalidate::compose_rules(- |
-
529 | -! | -
- shinyvalidate::sv_optional(),- |
-
530 | -! | -
- rule_diff("row_facet")- |
-
531 | -- |
- )- |
-
532 | -- |
- )- |
-
533 | -- |
- )- |
-
534 | -- | - - | -
535 | -! | -
- iv_r <- reactive({- |
-
536 | -! | -
- iv_facet <- shinyvalidate::InputValidator$new()- |
-
537 | -! | -
- iv <- shinyvalidate::InputValidator$new()- |
-
538 | -! | -
- teal.transform::compose_and_enable_validators(iv, selector_list)- |
-
539 | -- |
- })- |
-
540 | -! | -
- iv_facet <- shinyvalidate::InputValidator$new()- |
-
541 | -! | -
- iv_facet$add_rule("add_density", ~ if (- |
-
542 | -! | -
- isTRUE(.) &&- |
-
543 | -- |
- (- |
-
544 | -! | -
- length(selector_list()$row_facet()$select) > 0L ||- |
-
545 | -! | -
- length(selector_list()$col_facet()$select) > 0L- |
-
546 | -- |
- )- |
-
547 | -- |
- ) {- |
-
548 | -! | -
- "Cannot add marginal density when Row or Column facetting has been selected"- |
-
549 | -- |
- })- |
-
550 | -! | -
- iv_facet$enable()- |
-
551 | -- | - - | -
552 | -! | -
- anl_merged_input <- teal.transform::merge_expression_srv(- |
-
553 | -! | -
- selector_list = selector_list,- |
-
554 | -! | -
- datasets = data,- |
-
555 | -! | -
- merge_function = "dplyr::inner_join"- |
-
556 | -- |
- )- |
-
557 | -- | - - | -
558 | -! | -
- anl_merged_q <- reactive({- |
-
559 | -! | -
- req(anl_merged_input())- |
-
560 | -! | -
- data() %>%- |
-
561 | -! | -
- teal.code::eval_code(as.expression(anl_merged_input()$expr)) %>%- |
-
562 | -! | -
- teal.code::eval_code(quote(ANL)) # used to display table when running show-r-code code- |
-
563 | -- |
- })- |
-
564 | -- | - - | -
565 | -! | -
- merged <- list(- |
-
566 | -! | -
- anl_input_r = anl_merged_input,- |
-
567 | -! | -
- anl_q_r = anl_merged_q- |
-
568 | -- |
- )- |
-
569 | -- | - - | -
570 | -! | -
- trend_line_is_applicable <- reactive({- |
-
571 | -! | -
- ANL <- merged$anl_q_r()[["ANL"]]- |
-
572 | -! | -
- x_var <- as.vector(merged$anl_input_r()$columns_source$x)- |
-
573 | -! | -
- y_var <- as.vector(merged$anl_input_r()$columns_source$y)- |
-
574 | -! | -
- length(x_var) > 0 && length(y_var) > 0 && is.numeric(ANL[[x_var]]) && is.numeric(ANL[[y_var]])- |
-
575 | -- |
- })- |
-
576 | -- | - - | -
577 | -! | -
- add_trend_line <- reactive({- |
-
578 | -! | -
- smoothing_degree <- as.integer(input$smoothing_degree)- |
-
579 | -! | -
- trend_line_is_applicable() && length(smoothing_degree) > 0- |
-
580 | -- |
- })- |
-
581 | -- | - - | -
582 | -! | -
- if (!is.null(color_by)) {- |
-
583 | -! | -
- observeEvent(- |
-
584 | -! | -
- eventExpr = merged$anl_input_r()$columns_source$color_by,- |
-
585 | -! | -
- handlerExpr = {- |
-
586 | -! | -
- color_by_var <- as.vector(merged$anl_input_r()$columns_source$color_by)- |
-
587 | -! | -
- if (length(color_by_var) > 0) {- |
-
588 | -! | -
- shinyjs::hide("color")- |
-
589 | -- |
- } else {- |
-
590 | -! | -
- shinyjs::show("color")- |
-
591 | -- |
- }- |
-
592 | -- |
- }- |
-
593 | -- |
- )- |
-
594 | -- |
- }- |
-
595 | -- | - - | -
596 | -! | -
- output$num_na_removed <- renderUI({- |
-
597 | -! | -
- if (add_trend_line()) {- |
-
598 | -! | -
- ANL <- merged$anl_q_r()[["ANL"]]- |
-
599 | -! | -
- x_var <- as.vector(merged$anl_input_r()$columns_source$x)- |
-
600 | -! | -
- y_var <- as.vector(merged$anl_input_r()$columns_source$y)- |
-
601 | -! | -
- if ((num_total_na <- nrow(ANL) - nrow(stats::na.omit(ANL[, c(x_var, y_var)]))) > 0) {- |
-
602 | -! | -
- shiny::tags$div(paste(num_total_na, "row(s) with missing values were removed"), shiny::tags$hr())- |
-
603 | -- |
- }- |
-
604 | -- |
- }- |
-
605 | -- |
- })- |
-
606 | -- | - - | -
607 | -! | -
- observeEvent(- |
-
608 | -! | -
- eventExpr = merged$anl_input_r()$columns_source[c("col_facet", "row_facet")],- |
-
609 | -! | -
- handlerExpr = {- |
-
610 | -! | -
- if (- |
-
611 | -! | -
- length(merged$anl_input_r()$columns_source$col_facet) == 0 &&- |
-
612 | -! | -
- length(merged$anl_input_r()$columns_source$row_facet) == 0- |
-
613 | -- |
- ) {- |
-
614 | -! | -
- shinyjs::hide("free_scales")- |
-
615 | -- |
- } else {- |
-
616 | -! | -
- shinyjs::show("free_scales")- |
-
617 | -- |
- }- |
-
618 | -- |
- }- |
-
619 | -- |
- )- |
-
620 | -- | - - | -
621 | -! | -
- output_q <- reactive({- |
-
622 | -! | -
- teal::validate_inputs(iv_r(), iv_facet)- |
-
623 | -- | - - | -
624 | -! | -
- ANL <- merged$anl_q_r()[["ANL"]]- |
-
625 | -- | - - | -
626 | -! | -
- x_var <- as.vector(merged$anl_input_r()$columns_source$x)- |
-
627 | -! | -
- y_var <- as.vector(merged$anl_input_r()$columns_source$y)- |
-
628 | -! | -
- color_by_var <- as.vector(merged$anl_input_r()$columns_source$color_by)- |
-
629 | -! | -
- size_by_var <- as.vector(merged$anl_input_r()$columns_source$size_by)- |
-
630 | -! | -
- row_facet_name <- if (length(merged$anl_input_r()$columns_source$row_facet) == 0) {- |
-
631 | -! | -
- character(0)- |
-
632 | -- |
- } else {- |
-
633 | -! | -
- as.vector(merged$anl_input_r()$columns_source$row_facet)- |
-
634 | -- |
- }- |
-
635 | -! | -
- col_facet_name <- if (length(merged$anl_input_r()$columns_source$col_facet) == 0) {- |
-
636 | -! | -
- character(0)- |
-
637 | -- |
- } else {- |
-
638 | -! | -
- as.vector(merged$anl_input_r()$columns_source$col_facet)- |
-
639 | -- |
- }- |
-
640 | -! | -
- alpha <- input$alpha- |
-
641 | -! | -
- size <- input$size- |
-
642 | -! | -
- rotate_xaxis_labels <- input$rotate_xaxis_labels- |
-
643 | -! | -
- add_density <- input$add_density- |
-
644 | -! | -
- ggtheme <- input$ggtheme- |
-
645 | -! | -
- rug_plot <- input$rug_plot- |
-
646 | -! | -
- color <- input$color- |
-
647 | -! | -
- shape <- `if`(is.null(input$shape) || identical(input$shape, ""), "circle", input$shape)- |
-
648 | -! | -
- smoothing_degree <- as.integer(input$smoothing_degree)- |
-
649 | -! | -
- ci <- input$ci- |
-
650 | -- | - - | -
651 | -! | -
- log_x <- input$log_x- |
-
652 | -! | -
- log_y <- input$log_y- |
-
653 | -- | - - | -
654 | -! | -
- validate(need(- |
-
655 | -! | -
- length(row_facet_name) == 0 || inherits(ANL[[row_facet_name]], c("character", "factor", "Date", "integer")),- |
-
656 | -! | -
- "`Row facetting` variable must be of class `character`, `factor`, `Date`, or `integer`"- |
-
657 | -- |
- ))- |
-
658 | -! | -
- validate(need(- |
-
659 | -! | -
- length(col_facet_name) == 0 || inherits(ANL[[col_facet_name]], c("character", "factor", "Date", "integer")),- |
-
660 | -! | -
- "`Column facetting` variable must be of class `character`, `factor`, `Date`, or `integer`"- |
-
661 | -- |
- ))- |
-
662 | -- | - - | -
663 | -! | -
- if (add_density && length(color_by_var) > 0) {- |
-
664 | -! | -
- validate(need(- |
-
665 | -! | -
- !is.numeric(ANL[[color_by_var]]),- |
-
666 | -! | -
- "Marginal plots cannot be produced when the points are colored by numeric variables.- |
-
667 | -! | -
- \n Uncheck the 'Add marginal density' checkbox to display the plot."- |
-
668 | -- |
- ))- |
-
669 | -! | -
- validate(need(- |
-
670 | -- |
- !(- |
-
671 | -! | -
- inherits(ANL[[color_by_var]], "Date") ||- |
-
672 | -! | -
- inherits(ANL[[color_by_var]], "POSIXct") ||- |
-
673 | -! | -
- inherits(ANL[[color_by_var]], "POSIXlt")- |
-
674 | -- |
- ),- |
-
675 | -! | -
- "Marginal plots cannot be produced when the points are colored by Date or POSIX variables.- |
-
676 | -! | -
- \n Uncheck the 'Add marginal density' checkbox to display the plot."- |
-
677 | -- |
- ))- |
-
678 | -- |
- }- |
-
679 | -- | - - | -
680 | -! | -
- teal::validate_has_data(ANL[, c(x_var, y_var)], 10, complete = TRUE, allow_inf = FALSE)- |
-
681 | -- | - - | -
682 | -! | -
- if (log_x) {- |
-
683 | -! | -
- validate(- |
-
684 | -! | -
- need(- |
-
685 | -! | -
- is.numeric(ANL[[x_var]]) && all(- |
-
686 | -! | -
- ANL[[x_var]] > 0 | is.na(ANL[[x_var]])- |
-
687 | -- |
- ),- |
-
688 | -! | -
- "X variable can only be log transformed if variable is numeric and all values are positive."- |
-
689 | -- |
- )- |
-
690 | -- |
- )- |
-
691 | -- |
- }- |
-
692 | -! | -
- if (log_y) {- |
-
693 | -! | -
- validate(- |
-
694 | -! | -
- need(- |
-
695 | -! | -
- is.numeric(ANL[[y_var]]) && all(- |
-
696 | -! | -
- ANL[[y_var]] > 0 | is.na(ANL[[y_var]])- |
-
697 | -- |
- ),- |
-
698 | -! | -
- "Y variable can only be log transformed if variable is numeric and all values are positive."- |
-
699 | -- |
- )- |
-
700 | -- |
- )- |
-
701 | -- |
- }- |
-
702 | -- | - - | -
703 | -! | -
- facet_cl <- facet_ggplot_call(- |
-
704 | -! | -
- row_facet_name,- |
-
705 | -! | -
- col_facet_name,- |
-
706 | -! | -
- free_x_scales = isTRUE(input$free_scales),- |
-
707 | -! | -
- free_y_scales = isTRUE(input$free_scales)- |
-
708 | -- |
- )- |
-
709 | -- | - - | -
710 | -! | -
- point_sizes <- if (length(size_by_var) > 0) {- |
-
711 | -! | -
- validate(need(is.numeric(ANL[[size_by_var]]), "Variable to size by must be numeric"))- |
-
712 | -! | -
- substitute(- |
-
713 | -! | -
- expr = size * ANL[[size_by_var]] / max(ANL[[size_by_var]], na.rm = TRUE),- |
-
714 | -! | -
- env = list(size = size, size_by_var = size_by_var)- |
-
715 | -- |
- )- |
-
716 | -- |
- } else {- |
-
717 | -! | -
- size- |
-
718 | -- |
- }- |
-
719 | -- | - - | -
720 | -! | -
- plot_q <- merged$anl_q_r()- |
-
721 | -- | - - | -
722 | -! | -
- if (log_x) {- |
-
723 | -! | -
- log_x_fn <- input$log_x_base- |
-
724 | -! | -
- plot_q <- teal.code::eval_code(- |
-
725 | -! | -
- object = plot_q,- |
-
726 | -! | -
- code = substitute(- |
-
727 | -! | -
- expr = ANL[, log_x_var] <- log_x_fn(ANL[, x_var]),- |
-
728 | -! | -
- env = list(- |
-
729 | -! | -
- x_var = x_var,- |
-
730 | -! | -
- log_x_fn = as.name(log_x_fn),- |
-
731 | -! | -
- log_x_var = paste0(log_x_fn, "_", x_var)- |
-
732 | -- |
- )- |
-
733 | -- |
- )- |
-
734 | -- |
- )- |
-
735 | -- |
- }- |
-
736 | -- | - - | -
737 | -! | -
- if (log_y) {- |
-
738 | -! | -
- log_y_fn <- input$log_y_base- |
-
739 | -! | -
- plot_q <- teal.code::eval_code(- |
-
740 | -! | -
- object = plot_q,- |
-
741 | -! | -
- code = substitute(- |
-
742 | -! | -
- expr = ANL[, log_y_var] <- log_y_fn(ANL[, y_var]),- |
-
743 | -! | -
- env = list(- |
-
744 | -! | -
- y_var = y_var,- |
-
745 | -! | -
- log_y_fn = as.name(log_y_fn),- |
-
746 | -! | -
- log_y_var = paste0(log_y_fn, "_", y_var)- |
-
747 | -- |
- )- |
-
748 | -- |
- )- |
-
749 | -- |
- )- |
-
750 | -- |
- }- |
-
751 | -- | - - | -
752 | -! | -
- pre_pro_anl <- if (input$show_count) {- |
-
753 | -! | -
- paste0(- |
-
754 | -! | -
- "ANL %>% dplyr::group_by(",- |
-
755 | -! | -
- paste(- |
-
756 | -! | -
- c(- |
-
757 | -! | -
- if (length(color_by_var) > 0 && inherits(ANL[[color_by_var]], c("factor", "character"))) color_by_var,- |
-
758 | -! | -
- row_facet_name,- |
-
759 | -! | -
- col_facet_name- |
-
760 | -- |
- ),- |
-
761 | -! | -
- collapse = ", "- |
-
762 | -- |
- ),- |
-
763 | -! | -
- ") %>% dplyr::mutate(n = dplyr::n()) %>% dplyr::ungroup()"- |
-
764 | -- |
- )- |
-
765 | -- |
- } else {- |
-
766 | -! | -
- "ANL"- |
-
767 | -- |
- }- |
-
768 | -- | - - | -
769 | -! | -
- plot_call <- substitute(expr = pre_pro_anl %>% ggplot(), env = list(pre_pro_anl = str2lang(pre_pro_anl)))- |
-
770 | -- | - - | -
771 | -! | -
- plot_call <- if (length(color_by_var) == 0) {- |
-
772 | -! | -
- substitute(- |
-
773 | -! | -
- expr = plot_call +- |
-
774 | -! | -
- ggplot2::aes(x = x_name, y = y_name) +- |
-
775 | -! | -
- ggplot2::geom_point(alpha = alpha_value, size = point_sizes, shape = shape_value, color = color_value),- |
-
776 | -! | -
- env = list(- |
-
777 | -! | -
- plot_call = plot_call,- |
-
778 | -! | -
- x_name = if (log_x) as.name(paste0(log_x_fn, "_", x_var)) else as.name(x_var),- |
-
779 | -! | -
- y_name = if (log_y) as.name(paste0(log_y_fn, "_", y_var)) else as.name(y_var),- |
-
780 | -! | -
- alpha_value = alpha,- |
-
781 | -! | -
- point_sizes = point_sizes,- |
-
782 | -! | -
- shape_value = shape,- |
-
783 | -! | -
- color_value = color- |
-
784 | -- |
- )- |
-
785 | -- |
- )- |
-
786 | -- |
- } else {- |
-
787 | -! | -
- substitute(- |
-
788 | -! | -
- expr = plot_call +- |
-
789 | -! | -
- ggplot2::aes(x = x_name, y = y_name, color = color_by_var_name) +- |
-
790 | -! | -
- ggplot2::geom_point(alpha = alpha_value, size = point_sizes, shape = shape_value),- |
-
791 | -! | -
- env = list(- |
-
792 | -! | -
- plot_call = plot_call,- |
-
793 | -! | -
- x_name = if (log_x) as.name(paste0(log_x_fn, "_", x_var)) else as.name(x_var),- |
-
794 | -! | -
- y_name = if (log_y) as.name(paste0(log_y_fn, "_", y_var)) else as.name(y_var),- |
-
795 | -! | -
- color_by_var_name = as.name(color_by_var),- |
-
796 | -! | -
- alpha_value = alpha,- |
-
797 | -! | -
- point_sizes = point_sizes,- |
-
798 | -! | -
- shape_value = shape- |
-
799 | -- |
- )- |
-
800 | -- |
- )- |
-
801 | -- |
- }- |
-
802 | -- | - - | -
803 | -! | -
- if (rug_plot) plot_call <- substitute(expr = plot_call + geom_rug(), env = list(plot_call = plot_call))- |
-
804 | -- | - - | -
805 | -! | -
- plot_label_generator <- function(rhs_formula = quote(y ~ 1),- |
-
806 | -! | -
- show_form = input$show_form,- |
-
807 | -! | -
- show_r2 = input$show_r2,- |
-
808 | -! | -
- show_count = input$show_count,- |
-
809 | -! | -
- pos = input$pos,- |
-
810 | -! | -
- label_size = input$label_size) {- |
-
811 | -! | -
- stopifnot(sum(show_form, show_r2, show_count) >= 1)- |
-
812 | -! | -
- aes_label <- paste0(- |
-
813 | -! | -
- "aes(",- |
-
814 | -! | -
- if (show_count) "n = n, ",- |
-
815 | -! | -
- "label = ",- |
-
816 | -! | -
- if (sum(show_form, show_r2, show_count) > 1) "paste(",- |
-
817 | -! | -
- paste(- |
-
818 | -! | -
- c(- |
-
819 | -! | -
- if (show_form) "stat(eq.label)",- |
-
820 | -! | -
- if (show_r2) "stat(adj.rr.label)",- |
-
821 | -! | -
- if (show_count) "paste('N ~`=`~', n)"- |
-
822 | -- |
- ),- |
-
823 | -! | -
- collapse = ", "- |
-
824 | -- |
- ),- |
-
825 | -! | -
- if (sum(show_form, show_r2, show_count) > 1) ", sep = '*\", \"*'))" else ")"- |
-
826 | -- |
- )- |
-
827 | -! | -
- label_geom <- substitute(- |
-
828 | -! | -
- expr = ggpmisc::stat_poly_eq(- |
-
829 | -! | -
- mapping = aes_label,- |
-
830 | -! | -
- formula = rhs_formula,- |
-
831 | -! | -
- parse = TRUE,- |
-
832 | -! | -
- label.x = pos,- |
-
833 | -! | -
- size = label_size- |
-
834 | -- |
- ),- |
-
835 | -! | -
- env = list(- |
-
836 | -! | -
- rhs_formula = rhs_formula,- |
-
837 | -! | -
- pos = pos,- |
-
838 | -! | -
- aes_label = str2lang(aes_label),- |
-
839 | -! | -
- label_size = label_size- |
-
840 | -- |
- )- |
-
841 | -- |
- )- |
-
842 | -! | -
- substitute(- |
-
843 | -! | -
- expr = plot_call + label_geom,- |
-
844 | -! | -
- env = list(- |
-
845 | -! | -
- plot_call = plot_call,- |
-
846 | -! | -
- label_geom = label_geom- |
-
847 | -- |
- )- |
-
848 | -- |
- )- |
-
849 | -- |
- }- |
-
850 | -- | - - | -
851 | -! | -
- if (trend_line_is_applicable()) {- |
-
852 | -! | -
- shinyjs::hide("line_msg")- |
-
853 | -! | -
- shinyjs::show("smoothing_degree")- |
-
854 | -! | -
- if (!add_trend_line()) {- |
-
855 | -! | -
- shinyjs::hide("ci")- |
-
856 | -! | -
- shinyjs::hide("color_sub")- |
-
857 | -! | -
- shinyjs::hide("show_form")- |
-
858 | -! | -
- shinyjs::hide("show_r2")- |
-
859 | -! | -
- if (input$show_count) {- |
-
860 | -! | -
- plot_call <- plot_label_generator(show_form = FALSE, show_r2 = FALSE)- |
-
861 | -! | -
- shinyjs::show("label_pos")- |
-
862 | -! | -
- shinyjs::show("label_size")- |
-
863 | -- |
- } else {- |
-
864 | -! | -
- shinyjs::hide("label_pos")- |
-
865 | -! | -
- shinyjs::hide("label_size")- |
-
866 | -- |
- }- |
-
867 | -- |
- } else {- |
-
868 | -! | -
- shinyjs::show("ci")- |
-
869 | -! | -
- shinyjs::show("show_form")- |
-
870 | -! | -
- shinyjs::show("show_r2")- |
-
871 | -! | -
- if (nrow(ANL) - nrow(stats::na.omit(ANL[, c(x_var, y_var)])) > 0) {- |
-
872 | -! | -
- plot_q <- teal.code::eval_code(- |
-
873 | -! | -
- plot_q,- |
-
874 | -! | -
- substitute(- |
-
875 | -! | -
- expr = ANL <- dplyr::filter(ANL, !is.na(x_var) & !is.na(y_var)),- |
-
876 | -! | -
- env = list(x_var = as.name(x_var), y_var = as.name(y_var))- |
-
877 | -- |
- )- |
-
878 | -- |
- )- |
-
879 | -- |
- }- |
-
880 | -! | -
- rhs_formula <- substitute(- |
-
881 | -! | -
- expr = y ~ poly(x, smoothing_degree, raw = TRUE),- |
-
882 | -! | -
- env = list(smoothing_degree = smoothing_degree)- |
-
883 | -- |
- )- |
-
884 | -! | -
- if (input$show_form || input$show_r2 || input$show_count) {- |
-
885 | -! | -
- plot_call <- plot_label_generator(rhs_formula = rhs_formula)- |
-
886 | -! | -
- shinyjs::show("label_pos")- |
-
887 | -! | -
- shinyjs::show("label_size")- |
-
888 | -- |
- } else {- |
-
889 | -! | -
- shinyjs::hide("label_pos")- |
-
890 | -! | -
- shinyjs::hide("label_size")- |
-
891 | -- |
- }- |
-
892 | -! | -
- plot_call <- substitute(- |
-
893 | -! | -
- expr = plot_call + ggplot2::geom_smooth(formula = rhs_formula, se = TRUE, level = ci, method = "lm"),- |
-
894 | -! | -
- env = list(plot_call = plot_call, rhs_formula = rhs_formula, ci = ci)- |
-
895 | -- |
- )- |
-
896 | -- |
- }- |
-
897 | -- |
- } else {- |
-
898 | -! | -
- shinyjs::hide("smoothing_degree")- |
-
899 | -! | -
- shinyjs::hide("ci")- |
-
900 | -! | -
- shinyjs::hide("color_sub")- |
-
901 | -! | -
- shinyjs::hide("show_form")- |
-
902 | -! | -
- shinyjs::hide("show_r2")- |
-
903 | -! | -
- if (input$show_count) {- |
-
904 | -! | -
- plot_call <- plot_label_generator(show_form = FALSE, show_r2 = FALSE)- |
-
905 | -! | -
- shinyjs::show("label_pos")- |
-
906 | -! | -
- shinyjs::show("label_size")- |
-
907 | -- |
- } else {- |
-
908 | -! | -
- shinyjs::hide("label_pos")- |
-
909 | -! | -
- shinyjs::hide("label_size")- |
-
910 | -- |
- }- |
-
911 | -! | -
- shinyjs::show("line_msg")- |
-
912 | -- |
- }- |
-
913 | -- | - - | -
914 | -! | -
- if (!is.null(facet_cl)) {- |
-
915 | -! | -
- plot_call <- substitute(expr = plot_call + facet_cl, env = list(plot_call = plot_call, facet_cl = facet_cl))- |
-
916 | -- |
- }- |
-
917 | -- | - - | -
918 | -! | -
- y_label <- varname_w_label(- |
-
919 | -! | -
- y_var,- |
-
920 | -! | -
- ANL,- |
-
921 | -! | -
- prefix = if (log_y) paste(log_y_fn, "(") else NULL,- |
-
922 | -! | -
- suffix = if (log_y) ")" else NULL- |
-
923 | -- |
- )- |
-
924 | -! | -
- x_label <- varname_w_label(- |
-
925 | -! | -
- x_var,- |
-
926 | -! | -
- ANL,- |
-
927 | -! | -
- prefix = if (log_x) paste(log_x_fn, "(") else NULL,- |
-
928 | -! | -
- suffix = if (log_x) ")" else NULL- |
-
929 | -- |
- )- |
-
930 | -- | - - | -
931 | -! | -
- dev_ggplot2_args <- teal.widgets::ggplot2_args(- |
-
932 | -! | -
- labs = list(y = y_label, x = x_label),- |
-
933 | -! | -
- theme = list(legend.position = "bottom")- |
-
934 | -- |
- )- |
-
935 | -- | - - | -
936 | -! | -
- if (rotate_xaxis_labels) {- |
-
937 | -! | -
- dev_ggplot2_args$theme[["axis.text.x"]] <- quote(element_text(angle = 45, hjust = 1))- |
-
938 | -- |
- }- |
-
939 | -- | - - | -
940 | -! | -
- all_ggplot2_args <- teal.widgets::resolve_ggplot2_args(- |
-
941 | -! | -
- user_plot = ggplot2_args,- |
-
942 | -! | -
- module_plot = dev_ggplot2_args- |
-
943 | -- |
- )- |
-
944 | -- | - - | -
945 | -! | -
- parsed_ggplot2_args <- teal.widgets::parse_ggplot2_args(all_ggplot2_args, ggtheme = ggtheme)- |
-
946 | -- | - - | -
947 | -- | - - | -
948 | -! | -
- if (add_density) {- |
-
949 | -! | -
- plot_call <- substitute(- |
-
950 | -! | -
- expr = ggExtra::ggMarginal(- |
-
951 | -! | -
- plot_call + labs + ggthemes + themes,- |
-
952 | -! | -
- type = "density",- |
-
953 | -! | -
- groupColour = group_colour- |
-
954 | -- |
- ),- |
-
955 | -! | -
- env = list(- |
-
956 | -! | -
- plot_call = plot_call,- |
-
957 | -! | -
- group_colour = if (length(color_by_var) > 0) TRUE else FALSE,- |
-
958 | -! | -
- labs = parsed_ggplot2_args$labs,- |
-
959 | -! | -
- ggthemes = parsed_ggplot2_args$ggtheme,- |
-
960 | -! | -
- themes = parsed_ggplot2_args$theme- |
-
961 | -- |
- )- |
-
962 | -- |
- )- |
-
963 | -- |
- } else {- |
-
964 | -! | -
- plot_call <- substitute(- |
-
965 | -! | -
- expr = plot_call +- |
-
966 | -! | -
- labs +- |
-
967 | -! | -
- ggthemes +- |
-
968 | -! | -
- themes,- |
-
969 | -! | -
- env = list(- |
-
970 | -! | -
- plot_call = plot_call,- |
-
971 | -! | -
- labs = parsed_ggplot2_args$labs,- |
-
972 | -! | -
- ggthemes = parsed_ggplot2_args$ggtheme,- |
-
973 | -! | -
- themes = parsed_ggplot2_args$theme- |
-
974 | -- |
- )- |
-
975 | -- |
- )- |
-
976 | -- |
- }- |
-
977 | -- | - - | -
978 | -! | -
- plot_call <- substitute(expr = p <- plot_call, env = list(plot_call = plot_call))- |
-
979 | -- | - - | -
980 | -! | -
- teal.code::eval_code(plot_q, plot_call) %>%- |
-
981 | -! | -
- teal.code::eval_code(quote(print(p)))- |
-
982 | -- |
- })- |
-
983 | -- | - - | -
984 | -! | -
- plot_r <- reactive(output_q()[["p"]])- |
-
985 | -- | - - | -
986 | -- |
- # Insert the plot into a plot_with_settings module from teal.widgets- |
-
987 | -! | -
- pws <- teal.widgets::plot_with_settings_srv(- |
-
988 | -! | -
- id = "scatter_plot",- |
-
989 | -! | -
- plot_r = plot_r,- |
-
990 | -! | -
- height = plot_height,- |
-
991 | -! | -
- width = plot_width,- |
-
992 | -! | -
- brushing = TRUE- |
-
993 | -- |
- )- |
-
994 | -- | - - | -
995 | -! | -
- output$data_table <- DT::renderDataTable({- |
-
996 | -! | -
- plot_brush <- pws$brush()- |
-
997 | -- | - - | -
998 | -! | -
- if (!is.null(plot_brush)) {- |
-
999 | -! | -
- validate(need(!input$add_density, "Brushing feature is currently not supported when plot has marginal density"))- |
-
1000 | -- |
- }- |
-
1001 | -- | - - | -
1002 | -! | -
- merged_data <- isolate(teal.code::dev_suppress(output_q()[["ANL"]]))- |
-
1003 | -- | - - | -
1004 | -! | -
- brushed_df <- teal.widgets::clean_brushedPoints(merged_data, plot_brush)- |
-
1005 | -! | -
- numeric_cols <- names(brushed_df)[- |
-
1006 | -! | -
- vapply(brushed_df, function(x) is.numeric(x) && !is.integer(x), FUN.VALUE = logical(1))- |
-
1007 | -- |
- ]- |
-
1008 | -- | - - | -
1009 | -! | -
- if (length(numeric_cols) > 0) {- |
-
1010 | -! | -
- DT::formatRound(- |
-
1011 | -! | -
- DT::datatable(brushed_df,- |
-
1012 | -! | -
- rownames = FALSE,- |
-
1013 | -! | -
- options = list(scrollX = TRUE, pageLength = input$data_table_rows)- |
-
1014 | -- |
- ),- |
-
1015 | -! | -
- numeric_cols,- |
-
1016 | -! | -
- table_dec- |
-
1017 | -- |
- )- |
-
1018 | -- |
- } else {- |
-
1019 | -! | -
- DT::datatable(brushed_df, rownames = FALSE, options = list(scrollX = TRUE, pageLength = input$data_table_rows))- |
-
1020 | -- |
- }- |
-
1021 | -- |
- })- |
-
1022 | -- | - - | -
1023 | -! | -
- teal.widgets::verbatim_popup_srv(- |
-
1024 | -! | -
- id = "warning",- |
-
1025 | -! | -
- verbatim_content = reactive(teal.code::get_warnings(output_q())),- |
-
1026 | -! | -
- title = "Warning",- |
-
1027 | -! | -
- disabled = reactive(is.null(teal.code::get_warnings(output_q())))- |
-
1028 | -- |
- )- |
-
1029 | -- | - - | -
1030 | -! | -
- teal.widgets::verbatim_popup_srv(- |
-
1031 | -! | -
- id = "rcode",- |
-
1032 | -! | -
- verbatim_content = reactive(teal.code::get_code(output_q())),- |
-
1033 | -! | -
- title = "R Code for scatterplot"- |
-
1034 | -- |
- )- |
-
1035 | -- | - - | -
1036 | -- |
- ### REPORTER- |
-
1037 | -! | -
- if (with_reporter) {- |
-
1038 | -! | -
- card_fun <- function(comment, label) {- |
-
1039 | -! | -
- card <- teal::report_card_template(- |
-
1040 | -! | -
- title = "Scatter Plot",- |
-
1041 | -! | -
- label = label,- |
-
1042 | -! | -
- with_filter = with_filter,- |
-
1043 | -! | -
- filter_panel_api = filter_panel_api- |
-
1044 | -- |
- )- |
-
1045 | -! | -
- card$append_text("Plot", "header3")- |
-
1046 | -! | -
- card$append_plot(plot_r(), dim = pws$dim())- |
-
1047 | -! | -
- if (!comment == "") {- |
-
1048 | -! | -
- card$append_text("Comment", "header3")- |
-
1049 | -! | -
- card$append_text(comment)- |
-
1050 | -- |
- }- |
-
1051 | -! | -
- card$append_src(teal.code::get_code(output_q()))- |
-
1052 | -! | -
- card- |
-
1053 | -- |
- }- |
-
1054 | -! | -
- teal.reporter::simple_reporter_srv("simple_reporter", reporter = reporter, card_fun = card_fun)- |
-
1055 | -- |
- }- |
-
1056 | -- |
- ###- |
-
1057 | -- |
- })- |
-
1058 | -- |
- }- |
-
1 | -- |
- #' `teal` module: Front page- |
-
2 | -- |
- #'- |
-
3 | -- |
- #' Creates a simple front page for `teal` applications, displaying- |
-
4 | -- |
- #' introductory text, tables, additional `html` or `shiny` tags, and footnotes.- |
-
5 | -- |
- #'- |
-
6 | -- |
- #' @inheritParams teal::module- |
-
7 | -- |
- #' @param header_text (`character` vector) text to be shown at the top of the module, for each- |
-
8 | -- |
- #' element, if named the name is shown first in bold as a header followed by the value. The first- |
-
9 | -- |
- #' element's header is displayed larger than the others.- |
-
10 | -- |
- #' @param tables (`named list` of `data.frame`s) tables to be shown in the module.- |
-
11 | -- |
- #' @param additional_tags (`shiny.tag.list` or `html`) additional `shiny` tags or `html` to be included after the table,- |
-
12 | -- |
- #' for example to include an image, `tagList(tags$img(src = "image.png"))` or to include further `html`,- |
-
13 | -- |
- #' `HTML("html text here")`.- |
-
14 | -- |
- #' @param footnotes (`character` vector) of text to be shown at the bottom of the module, for each- |
-
15 | -- |
- #' element, if named the name is shown first in bold, followed by the value.- |
-
16 | -- |
- #' @param show_metadata (`logical`) indicating whether the metadata of the datasets be available on the module.- |
-
17 | -- |
- #'- |
-
18 | -- |
- #' @inherit shared_params return- |
-
19 | -- |
- #'- |
-
20 | -- |
- #' @examples- |
-
21 | -- |
- #' data <- teal_data()- |
-
22 | -- |
- #' data <- within(data, {- |
-
23 | -- |
- #' require(nestcolor)- |
-
24 | -- |
- #' ADSL <- rADSL- |
-
25 | -- |
- #' attr(ADSL, "metadata") <- list("Author" = "NEST team", "data_source" = "synthetic data")- |
-
26 | -- |
- #' })- |
-
27 | -- |
- #' datanames(data) <- "ADSL"- |
-
28 | -- |
- #' join_keys(data) <- default_cdisc_join_keys[datanames(data)]- |
-
29 | -- |
- #'- |
-
30 | -- |
- #' table_1 <- data.frame(Info = c("A", "B"), Text = c("A", "B"))- |
-
31 | -- |
- #' table_2 <- data.frame(`Column 1` = c("C", "D"), `Column 2` = c(5.5, 6.6), `Column 3` = c("A", "B"))- |
-
32 | -- |
- #' table_3 <- data.frame(Info = c("E", "F"), Text = c("G", "H"))- |
-
33 | -- |
- #'- |
-
34 | -- |
- #' table_input <- list(- |
-
35 | -- |
- #' "Table 1" = table_1,- |
-
36 | -- |
- #' "Table 2" = table_2,- |
-
37 | -- |
- #' "Table 3" = table_3- |
-
38 | -- |
- #' )- |
-
39 | -- |
- #'- |
-
40 | -- |
- #' app <- init(- |
-
41 | -- |
- #' data = data,- |
-
42 | -- |
- #' modules = modules(- |
-
43 | -- |
- #' tm_front_page(- |
-
44 | -- |
- #' header_text = c(- |
-
45 | -- |
- #' "Important information" = "It can go here.",- |
-
46 | -- |
- #' "Other information" = "Can go here."- |
-
47 | -- |
- #' ),- |
-
48 | -- |
- #' tables = table_input,- |
-
49 | -- |
- #' additional_tags = HTML("Additional HTML or shiny tags go here <br>"),- |
-
50 | -- |
- #' footnotes = c("X" = "is the first footnote", "Y is the second footnote"),- |
-
51 | -- |
- #' show_metadata = TRUE- |
-
52 | -- |
- #' )- |
-
53 | -- |
- #' ),- |
-
54 | -- |
- #' header = tags$h1("Sample Application"),- |
-
55 | -- |
- #' footer = tags$p("Application footer"),- |
-
56 | -- |
- #' )- |
-
57 | -- |
- #'- |
-
58 | -- |
- #' if (interactive()) {- |
-
59 | -- |
- #' shinyApp(app$ui, app$server)- |
-
60 | -- |
- #' }- |
-
61 | -- |
- #'- |
-
62 | -- |
- #' @export- |
-
63 | -- |
- #'- |
-
64 | -- |
- tm_front_page <- function(label = "Front page",- |
-
65 | -- |
- header_text = character(0),- |
-
66 | -- |
- tables = list(),- |
-
67 | -- |
- additional_tags = tagList(),- |
-
68 | -- |
- footnotes = character(0),- |
-
69 | -- |
- show_metadata = FALSE) {- |
-
70 | -! | -
- logger::log_info("Initializing tm_front_page")- |
-
71 | -- | - - | -
72 | -- |
- # Start of assertions- |
-
73 | -! | -
- checkmate::assert_string(label)- |
-
74 | -! | -
- checkmate::assert_character(header_text, min.len = 0, any.missing = FALSE)- |
-
75 | -! | -
- checkmate::assert_list(tables, types = "data.frame", names = "named", any.missing = FALSE)- |
-
76 | -! | -
- checkmate::assert_multi_class(additional_tags, classes = c("shiny.tag.list", "html"))- |
-
77 | -! | -
- checkmate::assert_character(footnotes, min.len = 0, any.missing = FALSE)- |
-
78 | -! | -
- checkmate::assert_flag(show_metadata)- |
-
79 | -- |
- # End of assertions- |
-
80 | -- | - - | -
81 | -- |
- # Make UI args- |
-
82 | -! | -
- args <- as.list(environment())- |
-
83 | -- | - - | -
84 | -! | -
- module(- |
-
85 | -! | -
- label = label,- |
-
86 | -! | -
- server = srv_front_page,- |
-
87 | -! | -
- ui = ui_front_page,- |
-
88 | -! | -
- ui_args = args,- |
-
89 | -! | -
- server_args = list(tables = tables, show_metadata = show_metadata),- |
-
90 | -! | -
- datanames = if (show_metadata) "all" else NULL- |
-
91 | -- |
- )- |
-
92 | -- |
- }- |
-
93 | -- | - - | -
94 | -- |
- # UI function for the front page module- |
-
95 | -- |
- ui_front_page <- function(id, ...) {- |
-
96 | -! | -
- args <- list(...)- |
-
97 | -! | -
- ns <- NS(id)- |
-
98 | -- | - - | -
99 | -! | -
- tagList(- |
-
100 | -! | -
- include_css_files("custom"),- |
-
101 | -! | -
- tags$div(- |
-
102 | -! | -
- id = "front_page_content",- |
-
103 | -! | -
- class = "ml-8",- |
-
104 | -! | -
- tags$div(- |
-
105 | -! | -
- id = "front_page_headers",- |
-
106 | -! | -
- get_header_tags(args$header_text)- |
-
107 | -- |
- ),- |
-
108 | -! | -
- tags$div(- |
-
109 | -! | -
- id = "front_page_tables",- |
-
110 | -! | -
- class = "ml-4",- |
-
111 | -! | -
- get_table_tags(args$tables, ns)- |
-
112 | -- |
- ),- |
-
113 | -! | -
- tags$div(- |
-
114 | -! | -
- id = "front_page_custom_html",- |
-
115 | -! | -
- class = "my-4",- |
-
116 | -! | -
- args$additional_tags- |
-
117 | -- |
- ),- |
-
118 | -! | -
- if (args$show_metadata) {- |
-
119 | -! | -
- tags$div(- |
-
120 | -! | -
- id = "front_page_metabutton",- |
-
121 | -! | -
- class = "m-4",- |
-
122 | -! | -
- actionButton(ns("metadata_button"), "Show metadata")- |
-
123 | -- |
- )- |
-
124 | -- |
- },- |
-
125 | -! | -
- tags$footer(- |
-
126 | -! | -
- class = ".small",- |
-
127 | -! | -
- get_footer_tags(args$footnotes)- |
-
128 | -- |
- )- |
-
129 | -- |
- )- |
-
130 | -- |
- )- |
-
131 | -- |
- }- |
-
132 | -- | - - | -
133 | -- |
- # Server function for the front page module- |
-
134 | -- |
- srv_front_page <- function(id, data, tables, show_metadata) {- |
-
135 | -! | -
- checkmate::assert_class(data, "reactive")- |
-
136 | -! | -
- checkmate::assert_class(isolate(data()), "teal_data")- |
-
137 | -! | -
- moduleServer(id, function(input, output, session) {- |
-
138 | -! | -
- ns <- session$ns- |
-
139 | -- | - - | -
140 | -! | -
- lapply(seq_along(tables), function(idx) {- |
-
141 | -! | -
- output[[paste0("table_", idx)]] <- renderTable(- |
-
142 | -! | -
- tables[[idx]],- |
-
143 | -! | -
- bordered = TRUE,- |
-
144 | -! | -
- caption = names(tables)[idx],- |
-
145 | -! | -
- caption.placement = "top"- |
-
146 | -- |
- )- |
-
147 | -- |
- })- |
-
148 | -- | - - | -
149 | -! | -
- if (show_metadata) {- |
-
150 | -! | -
- observeEvent(- |
-
151 | -! | -
- input$metadata_button, showModal(- |
-
152 | -! | -
- modalDialog(- |
-
153 | -! | -
- title = "Metadata",- |
-
154 | -! | -
- dataTableOutput(ns("metadata_table")),- |
-
155 | -! | -
- size = "l",- |
-
156 | -! | -
- easyClose = TRUE- |
-
157 | -- |
- )- |
-
158 | -- |
- )- |
-
159 | -- |
- )- |
-
160 | -- | - - | -
161 | -! | -
- metadata_data_frame <- reactive({- |
-
162 | -! | -
- datanames <- teal.data::datanames(data())- |
-
163 | -! | -
- convert_metadata_to_dataframe(- |
-
164 | -! | -
- lapply(datanames, function(dataname) attr(data()[[dataname]], "metadata")),- |
-
165 | -! | -
- datanames- |
-
166 | -- |
- )- |
-
167 | -- |
- })- |
-
168 | -- | - - | -
169 | -! | -
- output$metadata_table <- renderDataTable({- |
-
170 | -! | -
- validate(need(nrow(metadata_data_frame()) > 0, "The data has no associated metadata"))- |
-
171 | -! | -
- metadata_data_frame()- |
-
172 | -- |
- })- |
-
173 | -- |
- }- |
-
174 | -- |
- })- |
-
175 | -- |
- }- |
-
176 | -- | - - | -
177 | -- |
- ## utils functions- |
-
178 | -- | - - | -
179 | -- |
- get_header_tags <- function(header_text) {- |
-
180 | -! | -
- if (length(header_text) == 0) {- |
-
181 | -! | -
- return(list())- |
-
182 | -- |
- }- |
-
183 | -- | - - | -
184 | -! | -
- get_single_header_tags <- function(header_text, p_text, header_tag = tags$h4) {- |
-
185 | -! | -
- tagList(- |
-
186 | -! | -
- tags$div(- |
-
187 | -! | -
- if (!is.null(header_text) && nchar(header_text) > 0) header_tag(header_text),- |
-
188 | -! | -
- tags$p(p_text)- |
-
189 | -- |
- )- |
-
190 | -- |
- )- |
-
191 | -- |
- }- |
-
192 | -- | - - | -
193 | -! | -
- header_tags <- get_single_header_tags(names(header_text[1]), header_text[1], header_tag = tags$h3)- |
-
194 | -! | -
- c(header_tags, mapply(get_single_header_tags, utils::tail(names(header_text), -1), utils::tail(header_text, -1)))- |
-
195 | -- |
- }- |
-
196 | -- | - - | -
197 | -- |
- get_table_tags <- function(tables, ns) {- |
-
198 | -! | -
- if (length(tables) == 0) {- |
-
199 | -! | -
- return(list())- |
-
200 | -- |
- }- |
-
201 | -! | -
- table_tags <- c(lapply(seq_along(tables), function(idx) {- |
-
202 | -! | -
- list(- |
-
203 | -! | -
- tableOutput(ns(paste0("table_", idx)))- |
-
204 | -- |
- )- |
-
205 | -- |
- }))- |
-
206 | -! | -
- return(table_tags)- |
-
207 | -- |
- }- |
-
208 | -- | - - | -
209 | -- |
- get_footer_tags <- function(footnotes) {- |
-
210 | -! | -
- if (length(footnotes) == 0) {- |
-
211 | -! | -
- return(list())- |
-
212 | -- |
- }- |
-
213 | -! | -
- bold_texts <- if (is.null(names(footnotes))) rep("", length(footnotes)) else names(footnotes)- |
-
214 | -! | -
- footnote_tags <- mapply(function(bold_text, value) {- |
-
215 | -! | -
- list(- |
-
216 | -! | -
- tags$div(- |
-
217 | -! | -
- tags$b(bold_text),- |
-
218 | -! | -
- value,- |
-
219 | -! | -
- tags$br()- |
-
220 | -- |
- )- |
-
221 | -- |
- )- |
-
222 | -! | -
- }, bold_text = bold_texts, value = footnotes)- |
-
223 | -- |
- }- |
-
224 | -- | - - | -
225 | -- |
- # take a list of metadata, one item per dataset (raw_metadata each element from datasets$get_metadata())- |
-
226 | -- |
- # and the corresponding datanames and output a data.frame with columns {Dataset, Name, Value}.- |
-
227 | -- |
- # which are, the Dataset the metadata came from, the metadata's name and value- |
-
228 | -- |
- convert_metadata_to_dataframe <- function(raw_metadata, datanames) {- |
-
229 | -4x | -
- output <- mapply(function(metadata, dataname) {- |
-
230 | -6x | -
- if (is.null(metadata)) {- |
-
231 | -2x | -
- return(data.frame(Dataset = character(0), Name = character(0), Value = character(0)))- |
-
232 | -- |
- }- |
-
233 | -4x | -
- return(data.frame(- |
-
234 | -4x | -
- Dataset = dataname,- |
-
235 | -4x | -
- Name = names(metadata),- |
-
236 | -4x | -
- Value = unname(unlist(lapply(metadata, as.character)))- |
-
237 | -- |
- ))- |
-
238 | -4x | -
- }, raw_metadata, datanames, SIMPLIFY = FALSE)- |
-
239 | -4x | -
- do.call(rbind, output)- |
-
240 | -- |
- }- |
-
1 | -- |
- #' `teal` module: Scatterplot and regression analysis- |
-
2 | -- |
- #'- |
-
3 | -- |
- #' Module for visualizing regression analysis, including scatterplots and- |
-
4 | -- |
- #' various regression diagnostics plots.- |
-
5 | -- |
- #' It allows users to explore the relationship between a set of regressors and a response variable,- |
-
6 | -- |
- #' visualize residuals, and identify outliers.- |
-
7 | -- |
- #'- |
-
8 | -- |
- #' @note For more examples, please see the vignette "Using regression plots" via- |
-
9 | -- |
- #' `vignette("using-regression-plots", package = "teal.modules.general")`.- |
-
10 | -- |
- #'- |
-
11 | -- |
- #' @inheritParams teal::module- |
-
12 | -- |
- #' @inheritParams shared_params- |
-
13 | -- |
- #' @param regressor (`data_extract_spec` or `list` of multiple `data_extract_spec`)- |
-
14 | -- |
- #' Regressor variables from an incoming dataset with filtering and selecting.- |
-
15 | -- |
- #' @param response (`data_extract_spec` or `list` of multiple `data_extract_spec`)- |
-
16 | -- |
- #' Response variables from an incoming dataset with filtering and selecting.- |
-
17 | -- |
- #' @param default_outlier_label (`character`) optional, default column selected to label outliers.- |
-
18 | -- |
- #' @param default_plot_type (`numeric`) optional, defaults to "Response vs Regressor".- |
-
19 | -- |
- #' 1. Response vs Regressor- |
-
20 | -- |
- #' 2. Residuals vs Fitted- |
-
21 | -- |
- #' 3. Normal Q-Q- |
-
22 | -- |
- #' 4. Scale-Location- |
-
23 | -- |
- #' 5. Cook's distance- |
-
24 | -- |
- #' 6. Residuals vs Leverage- |
-
25 | -- |
- #' 7. Cook's dist vs Leverage- |
-
26 | -- |
- #' @param label_segment_threshold (`numeric(1)` or `numeric(3)`)- |
-
27 | -- |
- #' Minimum distance between label and point on the plot that triggers the creation of- |
-
28 | -- |
- #' a line segment between the two.- |
-
29 | -- |
- #' This may happen when the label cannot be placed next to the point as it overlaps another- |
-
30 | -- |
- #' label or point.- |
-
31 | -- |
- #' The value is used as the `min.segment.length` parameter to the [ggrepel::geom_text_repel()] function.- |
-
32 | -- |
- #'- |
-
33 | -- |
- #' It can take the following forms:- |
-
34 | -- |
- #' - `numeric(1)`: Fixed value used for the minimum distance and the slider is not presented in the UI.- |
-
35 | -- |
- #' - `numeric(3)`: A slider is presented in the UI (under "Plot settings") to adjust the minimum distance dynamically.- |
-
36 | -- |
- #'- |
-
37 | -- |
- #' It takes the form of `c(value, min, max)` and it is passed to the `value_min_max`- |
-
38 | -- |
- #' argument in `teal.widgets::optionalSliderInputValMinMax`.- |
-
39 | -- |
- #'- |
-
40 | -- |
- #' @templateVar ggnames `r regression_names`- |
-
41 | -- |
- #' @template ggplot2_args_multi- |
-
42 | -- |
- #'- |
-
43 | -- |
- #' @inherit shared_params return- |
-
44 | -- |
- #'- |
-
45 | -- |
- #' @examples- |
-
46 | -- |
- #' # general data example- |
-
47 | -- |
- #' library(teal.widgets)- |
-
48 | -- |
- #'- |
-
49 | -- |
- #' data <- teal_data()- |
-
50 | -- |
- #' data <- within(data, {- |
-
51 | -- |
- #' require(nestcolor)- |
-
52 | -- |
- #' CO2 <- CO2- |
-
53 | -- |
- #' })- |
-
54 | -- |
- #' datanames(data) <- c("CO2")- |
-
55 | -- |
- #'- |
-
56 | -- |
- #' app <- init(- |
-
57 | -- |
- #' data = data,- |
-
58 | -- |
- #' modules = modules(- |
-
59 | -- |
- #' tm_a_regression(- |
-
60 | -- |
- #' label = "Regression",- |
-
61 | -- |
- #' response = data_extract_spec(- |
-
62 | -- |
- #' dataname = "CO2",- |
-
63 | -- |
- #' select = select_spec(- |
-
64 | -- |
- #' label = "Select variable:",- |
-
65 | -- |
- #' choices = "uptake",- |
-
66 | -- |
- #' selected = "uptake",- |
-
67 | -- |
- #' multiple = FALSE,- |
-
68 | -- |
- #' fixed = TRUE- |
-
69 | -- |
- #' )- |
-
70 | -- |
- #' ),- |
-
71 | -- |
- #' regressor = data_extract_spec(- |
-
72 | -- |
- #' dataname = "CO2",- |
-
73 | -- |
- #' select = select_spec(- |
-
74 | -- |
- #' label = "Select variables:",- |
-
75 | -- |
- #' choices = variable_choices(data[["CO2"]], c("conc", "Treatment")),- |
-
76 | -- |
- #' selected = "conc",- |
-
77 | -- |
- #' multiple = TRUE,- |
-
78 | -- |
- #' fixed = FALSE- |
-
79 | -- |
- #' )- |
-
80 | -- |
- #' ),- |
-
81 | -- |
- #' ggplot2_args = ggplot2_args(- |
-
82 | -- |
- #' labs = list(subtitle = "Plot generated by Regression Module")- |
-
83 | -- |
- #' )- |
-
84 | -- |
- #' )- |
-
85 | -- |
- #' )- |
-
86 | -- |
- #' )- |
-
87 | -- |
- #' if (interactive()) {- |
-
88 | -- |
- #' shinyApp(app$ui, app$server)- |
-
89 | -- |
- #' }- |
-
90 | -- |
- #'- |
-
91 | -- |
- #' # CDISC data example- |
-
92 | -- |
- #' library(teal.widgets)- |
-
93 | -- |
- #'- |
-
94 | -- |
- #' data <- teal_data()- |
-
95 | -- |
- #' data <- within(data, {- |
-
96 | -- |
- #' require(nestcolor)- |
-
97 | -- |
- #' ADSL <- rADSL- |
-
98 | -- |
- #' })- |
-
99 | -- |
- #' datanames(data) <- "ADSL"- |
-
100 | -- |
- #' join_keys(data) <- default_cdisc_join_keys[datanames(data)]- |
-
101 | -- |
- #'- |
-
102 | -- |
- #' app <- init(- |
-
103 | -- |
- #' data = data,- |
-
104 | -- |
- #' modules = modules(- |
-
105 | -- |
- #' tm_a_regression(- |
-
106 | -- |
- #' label = "Regression",- |
-
107 | -- |
- #' response = data_extract_spec(- |
-
108 | -- |
- #' dataname = "ADSL",- |
-
109 | -- |
- #' select = select_spec(- |
-
110 | -- |
- #' label = "Select variable:",- |
-
111 | -- |
- #' choices = "BMRKR1",- |
-
112 | -- |
- #' selected = "BMRKR1",- |
-
113 | -- |
- #' multiple = FALSE,- |
-
114 | -- |
- #' fixed = TRUE- |
-
115 | -- |
- #' )- |
-
116 | -- |
- #' ),- |
-
117 | -- |
- #' regressor = data_extract_spec(- |
-
118 | -- |
- #' dataname = "ADSL",- |
-
119 | -- |
- #' select = select_spec(- |
-
120 | -- |
- #' label = "Select variables:",- |
-
121 | -- |
- #' choices = variable_choices(data[["ADSL"]], c("AGE", "SEX", "RACE")),- |
-
122 | -- |
- #' selected = "AGE",- |
-
123 | -- |
- #' multiple = TRUE,- |
-
124 | -- |
- #' fixed = FALSE- |
-
125 | -- |
- #' )- |
-
126 | -- |
- #' ),- |
-
127 | -- |
- #' ggplot2_args = ggplot2_args(- |
-
128 | -- |
- #' labs = list(subtitle = "Plot generated by Regression Module")- |
-
129 | -- |
- #' )- |
-
130 | -- |
- #' )- |
-
131 | -- |
- #' )- |
-
132 | -- |
- #' )- |
-
133 | -- |
- #' if (interactive()) {- |
-
134 | -- |
- #' shinyApp(app$ui, app$server)- |
-
135 | -- |
- #' }- |
-
136 | -- |
- #'- |
-
137 | -- |
- #' @export- |
-
138 | -- |
- #'- |
-
139 | -- |
- tm_a_regression <- function(label = "Regression Analysis",- |
-
140 | -- |
- regressor,- |
-
141 | -- |
- response,- |
-
142 | -- |
- plot_height = c(600, 200, 2000),- |
-
143 | -- |
- plot_width = NULL,- |
-
144 | -- |
- alpha = c(1, 0, 1),- |
-
145 | -- |
- size = c(2, 1, 8),- |
-
146 | -- |
- ggtheme = c("gray", "bw", "linedraw", "light", "dark", "minimal", "classic", "void"),- |
-
147 | -- |
- ggplot2_args = teal.widgets::ggplot2_args(),- |
-
148 | -- |
- pre_output = NULL,- |
-
149 | -- |
- post_output = NULL,- |
-
150 | -- |
- default_plot_type = 1,- |
-
151 | -- |
- default_outlier_label = "USUBJID",- |
-
152 | -- |
- label_segment_threshold = c(0.5, 0, 10)) {- |
-
153 | -! | -
- logger::log_info("Initializing tm_a_regression")- |
-
154 | -- | - - | -
155 | -- |
- # Normalize the parameters- |
-
156 | -! | -
- if (inherits(regressor, "data_extract_spec")) regressor <- list(regressor)- |
-
157 | -! | -
- if (inherits(response, "data_extract_spec")) response <- list(response)- |
-
158 | -! | -
- if (inherits(ggplot2_args, "ggplot2_args")) ggplot2_args <- list(default = ggplot2_args)- |
-
159 | -- | - - | -
160 | -- |
- # Start of assertions- |
-
161 | -! | -
- checkmate::assert_string(label)- |
-
162 | -! | -
- checkmate::assert_list(regressor, types = "data_extract_spec")- |
-
163 | -- | - - | -
164 | -! | -
- checkmate::assert_list(response, types = "data_extract_spec")- |
-
165 | -! | -
- assert_single_selection(response)- |
-
166 | -- | - - | -
167 | -! | -
- checkmate::assert_numeric(plot_height, len = 3, any.missing = FALSE, finite = TRUE)- |
-
168 | -! | -
- checkmate::assert_numeric(plot_height[1], lower = plot_height[2], upper = plot_height[3], .var.name = "plot_height")- |
-
169 | -- | - - | -
170 | -! | -
- checkmate::assert_numeric(plot_width, len = 3, any.missing = FALSE, null.ok = TRUE, finite = TRUE)- |
-
171 | -! | -
- checkmate::assert_numeric(- |
-
172 | -! | -
- plot_width[1],- |
-
173 | -! | -
- lower = plot_width[2],- |
-
174 | -! | -
- upper = plot_width[3],- |
-
175 | -! | -
- null.ok = TRUE,- |
-
176 | -! | -
- .var.name = "plot_width"- |
-
177 | -- |
- )- |
-
178 | -- | - - | -
179 | -! | -
- if (length(alpha) == 1) {- |
-
180 | -! | -
- checkmate::assert_numeric(alpha, any.missing = FALSE, finite = TRUE)- |
-
181 | -- |
- } else {- |
-
182 | -! | -
- checkmate::assert_numeric(alpha, len = 3, any.missing = FALSE, finite = TRUE)- |
-
183 | -! | -
- checkmate::assert_numeric(alpha[1], lower = alpha[2], upper = alpha[3], .var.name = "alpha")- |
-
184 | -- |
- }- |
-
185 | -- | - - | -
186 | -! | -
- if (length(size) == 1) {- |
-
187 | -! | -
- checkmate::assert_numeric(size, any.missing = FALSE, finite = TRUE)- |
-
188 | -- |
- } else {- |
-
189 | -! | -
- checkmate::assert_numeric(size, len = 3, any.missing = FALSE, finite = TRUE)- |
-
190 | -! | -
- checkmate::assert_numeric(size[1], lower = size[2], upper = size[3], .var.name = "size")- |
-
191 | -- |
- }- |
-
192 | -- | - - | -
193 | -! | -
- ggtheme <- match.arg(ggtheme)- |
-
194 | -- | - - | -
195 | -! | -
- plot_choices <- c(- |
-
196 | -! | -
- "Response vs Regressor", "Residuals vs Fitted", "Normal Q-Q", "Scale-Location",- |
-
197 | -! | -
- "Cook's distance", "Residuals vs Leverage", "Cook's dist vs Leverage"- |
-
198 | -- |
- )- |
-
199 | -! | -
- checkmate::assert_list(ggplot2_args, types = "ggplot2_args")- |
-
200 | -! | -
- checkmate::assert_subset(names(ggplot2_args), c("default", plot_choices))- |
-
201 | -- | - - | -
202 | -! | -
- checkmate::assert_multi_class(pre_output, c("shiny.tag", "shiny.tag.list", "html"), null.ok = TRUE)- |
-
203 | -! | -
- checkmate::assert_multi_class(post_output, c("shiny.tag", "shiny.tag.list", "html"), null.ok = TRUE)- |
-
204 | -! | -
- checkmate::assert_choice(default_plot_type, seq.int(1L, length(plot_choices)))- |
-
205 | -! | -
- checkmate::assert_string(default_outlier_label)- |
-
206 | -- | - - | -
207 | -! | -
- if (length(label_segment_threshold) == 1) {- |
-
208 | -! | -
- checkmate::assert_numeric(label_segment_threshold, any.missing = FALSE, finite = TRUE)- |
-
209 | -- |
- } else {- |
-
210 | -! | -
- checkmate::assert_numeric(label_segment_threshold, len = 3, any.missing = FALSE, finite = TRUE)- |
-
211 | -! | -
- checkmate::assert_numeric(- |
-
212 | -! | -
- label_segment_threshold[1],- |
-
213 | -! | -
- lower = label_segment_threshold[2],- |
-
214 | -! | -
- upper = label_segment_threshold[3],- |
-
215 | -! | -
- .var.name = "label_segment_threshold"- |
-
216 | -- |
- )- |
-
217 | -- |
- }- |
-
218 | -- |
- # End of assertions- |
-
219 | -- | - - | -
220 | -- |
- # Make UI args- |
-
221 | -! | -
- args <- as.list(environment())- |
-
222 | -! | -
- args[["plot_choices"]] <- plot_choices- |
-
223 | -! | -
- data_extract_list <- list(- |
-
224 | -! | -
- regressor = regressor,- |
-
225 | -! | -
- response = response- |
-
226 | -- |
- )- |
-
227 | -- | - - | -
228 | -! | -
- module(- |
-
229 | -! | -
- label = label,- |
-
230 | -! | -
- server = srv_a_regression,- |
-
231 | -! | -
- ui = ui_a_regression,- |
-
232 | -! | -
- ui_args = args,- |
-
233 | -! | -
- server_args = c(- |
-
234 | -! | -
- data_extract_list,- |
-
235 | -! | -
- list(- |
-
236 | -! | -
- plot_height = plot_height,- |
-
237 | -! | -
- plot_width = plot_width,- |
-
238 | -! | -
- default_outlier_label = default_outlier_label,- |
-
239 | -! | -
- ggplot2_args = ggplot2_args- |
-
240 | -- |
- )- |
-
241 | -- |
- ),- |
-
242 | -! | -
- datanames = teal.transform::get_extract_datanames(data_extract_list)- |
-
243 | -- |
- )- |
-
244 | -- |
- }- |
-
245 | -- | - - | -
246 | -- |
- # UI function for the regression module- |
-
247 | -- |
- ui_a_regression <- function(id, ...) {- |
-
248 | -! | -
- ns <- NS(id)- |
-
249 | -! | -
- args <- list(...)- |
-
250 | -! | -
- is_single_dataset_value <- teal.transform::is_single_dataset(args$regressor, args$response)- |
-
251 | -- | - - | -
252 | -! | -
- teal.widgets::standard_layout(- |
-
253 | -! | -
- output = teal.widgets::white_small_well(tags$div(- |
-
254 | -! | -
- teal.widgets::plot_with_settings_ui(id = ns("myplot")),- |
-
255 | -! | -
- tags$div(verbatimTextOutput(ns("text")))- |
-
256 | -- |
- )),- |
-
257 | -! | -
- encoding = div(- |
-
258 | -- |
- ### Reporter- |
-
259 | -! | -
- teal.reporter::simple_reporter_ui(ns("simple_reporter")),- |
-
260 | -- |
- ###- |
-
261 | -! | -
- tags$label("Encodings", class = "text-primary"),- |
-
262 | -! | -
- teal.transform::datanames_input(args[c("response", "regressor")]),- |
-
263 | -! | -
- teal.transform::data_extract_ui(- |
-
264 | -! | -
- id = ns("response"),- |
-
265 | -! | -
- label = "Response variable",- |
-
266 | -! | -
- data_extract_spec = args$response,- |
-
267 | -! | -
- is_single_dataset = is_single_dataset_value- |
-
268 | -- |
- ),- |
-
269 | -! | -
- teal.transform::data_extract_ui(- |
-
270 | -! | -
- id = ns("regressor"),- |
-
271 | -! | -
- label = "Regressor variables",- |
-
272 | -! | -
- data_extract_spec = args$regressor,- |
-
273 | -! | -
- is_single_dataset = is_single_dataset_value- |
-
274 | -- |
- ),- |
-
275 | -! | -
- radioButtons(- |
-
276 | -! | -
- ns("plot_type"),- |
-
277 | -! | -
- label = "Plot type:",- |
-
278 | -! | -
- choices = args$plot_choices,- |
-
279 | -! | -
- selected = args$plot_choices[args$default_plot_type]- |
-
280 | -- |
- ),- |
-
281 | -! | -
- checkboxInput(ns("show_outlier"), label = "Display outlier labels", value = TRUE),- |
-
282 | -! | -
- conditionalPanel(- |
-
283 | -! | -
- condition = "input['show_outlier']",- |
-
284 | -! | -
- ns = ns,- |
-
285 | -! | -
- teal.widgets::optionalSliderInput(- |
-
286 | -! | -
- ns("outlier"),- |
-
287 | -! | -
- div(- |
-
288 | -! | -
- class = "teal-tooltip",- |
-
289 | -! | -
- tagList(- |
-
290 | -! | -
- "Outlier definition:",- |
-
291 | -! | -
- icon("circle-info"),- |
-
292 | -! | -
- span(- |
-
293 | -! | -
- class = "tooltiptext",- |
-
294 | -! | -
- paste(- |
-
295 | -! | -
- "Use the slider to choose the cut-off value to define outliers.",- |
-
296 | -! | -
- "Points with a Cook's distance greater than",- |
-
297 | -! | -
- "the value on the slider times the mean of the Cook's distance of the dataset will have labels."- |
-
298 | -- |
- )- |
-
299 | -- |
- )- |
-
300 | -- |
- )- |
-
301 | -- |
- ),- |
-
302 | -! | -
- min = 1, max = 10, value = 9, ticks = FALSE, step = .1- |
-
303 | -- |
- ),- |
-
304 | -! | -
- teal.widgets::optionalSelectInput(- |
-
305 | -! | -
- ns("label_var"),- |
-
306 | -! | -
- multiple = FALSE,- |
-
307 | -! | -
- label = "Outlier label"- |
-
308 | -- |
- )- |
-
309 | -- |
- ),- |
-
310 | -! | -
- teal.widgets::panel_group(- |
-
311 | -! | -
- teal.widgets::panel_item(- |
-
312 | -! | -
- title = "Plot settings",- |
-
313 | -! | -
- teal.widgets::optionalSliderInputValMinMax(ns("alpha"), "Opacity:", args$alpha, ticks = FALSE),- |
-
314 | -! | -
- teal.widgets::optionalSliderInputValMinMax(ns("size"), "Points size:", args$size, ticks = FALSE),- |
-
315 | -! | -
- teal.widgets::optionalSliderInputValMinMax(- |
-
316 | -! | -
- inputId = ns("label_min_segment"),- |
-
317 | -! | -
- label = div(- |
-
318 | -! | -
- class = "teal-tooltip",- |
-
319 | -! | -
- tagList(- |
-
320 | -! | -
- "Label min. segment:",- |
-
321 | -! | -
- icon("circle-info"),- |
-
322 | -! | -
- span(- |
-
323 | -! | -
- class = "tooltiptext",- |
-
324 | -! | -
- paste(- |
-
325 | -! | -
- "Use the slider to choose the cut-off value to define minimum distance between label and point",- |
-
326 | -! | -
- "that generates a line segment.",- |
-
327 | -! | -
- "It's only valid when 'Display outlier labels' is checked."- |
-
328 | -- |
- )- |
-
329 | -- |
- )- |
-
330 | -- |
- )- |
-
331 | -- |
- ),- |
-
332 | -! | -
- value_min_max = args$label_segment_threshold,- |
-
333 | -- |
- # Extra parameters to sliderInput- |
-
334 | -! | -
- ticks = FALSE,- |
-
335 | -! | -
- step = .1,- |
-
336 | -! | -
- round = FALSE- |
-
337 | -- |
- ),- |
-
338 | -! | -
- selectInput(- |
-
339 | -! | -
- inputId = ns("ggtheme"),- |
-
340 | -! | -
- label = "Theme (by ggplot):",- |
-
341 | -! | -
- choices = ggplot_themes,- |
-
342 | -! | -
- selected = args$ggtheme,- |
-
343 | -! | -
- multiple = FALSE- |
-
344 | -- |
- )- |
-
345 | -- |
- )- |
-
346 | -- |
- )- |
-
347 | -- |
- ),- |
-
348 | -! | -
- forms = tagList(- |
-
349 | -! | -
- teal.widgets::verbatim_popup_ui(ns("warning"), "Show Warnings"),- |
-
350 | -! | -
- teal.widgets::verbatim_popup_ui(ns("rcode"), "Show R code")- |
-
351 | -- |
- ),- |
-
352 | -! | -
- pre_output = args$pre_output,- |
-
353 | -! | -
- post_output = args$post_output- |
-
354 | -- |
- )- |
-
355 | -- |
- }- |
-
356 | -- | - - | -
357 | -- |
- # Server function for the regression module- |
-
358 | -- |
- srv_a_regression <- function(id,- |
-
359 | -- |
- data,- |
-
360 | -- |
- reporter,- |
-
361 | -- |
- filter_panel_api,- |
-
362 | -- |
- response,- |
-
363 | -- |
- regressor,- |
-
364 | -- |
- plot_height,- |
-
365 | -- |
- plot_width,- |
-
366 | -- |
- ggplot2_args,- |
-
367 | -- |
- default_outlier_label) {- |
-
368 | -! | -
- with_reporter <- !missing(reporter) && inherits(reporter, "Reporter")- |
-
369 | -! | -
- with_filter <- !missing(filter_panel_api) && inherits(filter_panel_api, "FilterPanelAPI")- |
-
370 | -! | -
- checkmate::assert_class(data, "reactive")- |
-
371 | -! | -
- checkmate::assert_class(isolate(data()), "teal_data")- |
-
372 | -! | -
- moduleServer(id, function(input, output, session) {- |
-
373 | -! | -
- rule_rvr1 <- function(value) {- |
-
374 | -! | -
- if (isTRUE(input$plot_type == "Response vs Regressor")) {- |
-
375 | -! | -
- if (length(value) > 1L) {- |
-
376 | -! | -
- "This plot can only have one regressor."- |
-
377 | -- |
- }- |
-
378 | -- |
- }- |
-
379 | -- |
- }- |
-
380 | -! | -
- rule_rvr2 <- function(other) {- |
-
381 | -! | -
- function(value) {- |
-
382 | -! | -
- if (isTRUE(input$plot_type == "Response vs Regressor")) {- |
-
383 | -! | -
- otherval <- selector_list()[[other]]()$select- |
-
384 | -! | -
- if (isTRUE(value == otherval)) {- |
-
385 | -! | -
- "Response and Regressor must be different."- |
-
386 | -- |
- }- |
-
387 | -- |
- }- |
-
388 | -- |
- }- |
-
389 | -- |
- }- |
-
390 | -- | - - | -
391 | -! | -
- selector_list <- teal.transform::data_extract_multiple_srv(- |
-
392 | -! | -
- data_extract = list(response = response, regressor = regressor),- |
-
393 | -! | -
- datasets = data,- |
-
394 | -! | -
- select_validation_rule = list(- |
-
395 | -! | -
- regressor = shinyvalidate::compose_rules(- |
-
396 | -! | -
- shinyvalidate::sv_required("At least one regressor should be selected."),- |
-
397 | -! | -
- rule_rvr1,- |
-
398 | -! | -
- rule_rvr2("response")- |
-
399 | -- |
- ),- |
-
400 | -! | -
- response = shinyvalidate::compose_rules(- |
-
401 | -! | -
- shinyvalidate::sv_required("At least one response should be selected."),- |
-
402 | -! | -
- rule_rvr2("regressor")- |
-
403 | -- |
- )- |
-
404 | -- |
- )- |
-
405 | -- |
- )- |
-
406 | -- | - - | -
407 | -! | -
- iv_r <- reactive({- |
-
408 | -! | -
- iv <- shinyvalidate::InputValidator$new()- |
-
409 | -! | -
- teal.transform::compose_and_enable_validators(iv, selector_list)- |
-
410 | -- |
- })- |
-
411 | -- | - - | -
412 | -! | -
- iv_out <- shinyvalidate::InputValidator$new()- |
-
413 | -! | -
- iv_out$condition(~ isTRUE(input$show_outlier))- |
-
414 | -! | -
- iv_out$add_rule("label_var", shinyvalidate::sv_required("Please provide an `Outlier label` variable"))- |
-
415 | -! | -
- iv_out$enable()- |
-
416 | -- | - - | -
417 | -! | -
- anl_merged_input <- teal.transform::merge_expression_srv(- |
-
418 | -! | -
- selector_list = selector_list,- |
-
419 | -! | -
- datasets = data- |
-
420 | -- |
- )- |
-
421 | -- | - - | -
422 | -! | -
- regression_var <- reactive({- |
-
423 | -! | -
- teal::validate_inputs(iv_r())- |
-
424 | -- | - - | -
425 | -! | -
- list(- |
-
426 | -! | -
- response = as.vector(anl_merged_input()$columns_source$response),- |
-
427 | -! | -
- regressor = as.vector(anl_merged_input()$columns_source$regressor)- |
-
428 | -- |
- )- |
-
429 | -- |
- })- |
-
430 | -- | - - | -
431 | -! | -
- anl_merged_q <- reactive({- |
-
432 | -! | -
- req(anl_merged_input())- |
-
433 | -! | -
- data() %>%- |
-
434 | -! | -
- teal.code::eval_code(as.expression(anl_merged_input()$expr))- |
-
435 | -- |
- })- |
-
436 | -- | - - | -
437 | -- |
- # sets qenv object and populates it with data merge call and fit expression- |
-
438 | -! | -
- fit_r <- reactive({- |
-
439 | -! | -
- ANL <- anl_merged_q()[["ANL"]]- |
-
440 | -! | -
- teal::validate_has_data(ANL, 10)- |
-
441 | -- | - - | -
442 | -! | -
- validate(need(is.numeric(ANL[regression_var()$response][[1]]), "Response variable should be numeric."))- |
-
443 | -- | - - | -
444 | -! | -
- teal::validate_has_data(- |
-
445 | -! | -
- ANL[, c(regression_var()$response, regression_var()$regressor)], 10,- |
-
446 | -! | -
- complete = TRUE, allow_inf = FALSE- |
-
447 | -- |
- )- |
-
448 | -- | - - | -
449 | -! | -
- form <- stats::as.formula(- |
-
450 | -! | -
- paste(- |
-
451 | -! | -
- regression_var()$response,- |
-
452 | -! | -
- paste(- |
-
453 | -! | -
- regression_var()$regressor,- |
-
454 | -! | -
- collapse = " + "- |
-
455 | -- |
- ),- |
-
456 | -! | -
- sep = " ~ "- |
-
457 | -- |
- )- |
-
458 | -- |
- )- |
-
459 | -- | - - | -
460 | -! | -
- if (input$show_outlier) {- |
-
461 | -! | -
- opts <- teal.transform::variable_choices(ANL)- |
-
462 | -! | -
- selected <- if (!is.null(isolate(input$label_var)) && isolate(input$label_var) %in% as.character(opts)) {- |
-
463 | -! | -
- isolate(input$label_var)- |
-
464 | -- |
- } else {- |
-
465 | -! | -
- if (length(opts[as.character(opts) == default_outlier_label]) == 0) {- |
-
466 | -! | -
- opts[[1]]- |
-
467 | -- |
- } else {- |
-
468 | -! | -
- opts[as.character(opts) == default_outlier_label]- |
-
469 | -- |
- }- |
-
470 | -- |
- }- |
-
471 | -! | -
- teal.widgets::updateOptionalSelectInput(- |
-
472 | -! | -
- session = session,- |
-
473 | -! | -
- inputId = "label_var",- |
-
474 | -! | -
- choices = opts,- |
-
475 | -! | -
- selected = selected- |
-
476 | -- |
- )- |
-
477 | -- | - - | -
478 | -! | -
- data <- fortify(stats::lm(form, data = ANL))- |
-
479 | -! | -
- cooksd <- data$.cooksd[!is.nan(data$.cooksd)]- |
-
480 | -! | -
- max_outlier <- max(ceiling(max(cooksd) / mean(cooksd)), 2)- |
-
481 | -! | -
- cur_outlier <- isolate(input$outlier)- |
-
482 | -! | -
- updateSliderInput(- |
-
483 | -! | -
- session = session,- |
-
484 | -! | -
- inputId = "outlier",- |
-
485 | -! | -
- min = 1,- |
-
486 | -! | -
- max = max_outlier,- |
-
487 | -! | -
- value = if (cur_outlier < max_outlier) cur_outlier else max_outlier * .9- |
-
488 | -- |
- )- |
-
489 | -- |
- }- |
-
490 | -- | - - | -
491 | -! | -
- anl_merged_q() %>%- |
-
492 | -! | -
- teal.code::eval_code(substitute(fit <- stats::lm(form, data = ANL), env = list(form = form))) %>%- |
-
493 | -! | -
- teal.code::eval_code(quote({- |
-
494 | -! | -
- for (regressor in names(fit$contrasts)) {- |
-
495 | -! | -
- alts <- paste0(levels(ANL[[regressor]]), collapse = "|")- |
-
496 | -! | -
- names(fit$coefficients) <- gsub(- |
-
497 | -! | -
- paste0("^(", regressor, ")(", alts, ")$"), paste0("\\1", ": ", "\\2"), names(fit$coefficients)- |
-
498 | -- |
- )- |
-
499 | -- |
- }- |
-
500 | -- |
- })) %>%- |
-
501 | -! | -
- teal.code::eval_code(quote(summary(fit)))- |
-
502 | -- |
- })- |
-
503 | -- | - - | -
504 | -! | -
- label_col <- reactive({- |
-
505 | -! | -
- teal::validate_inputs(iv_out)- |
-
506 | -- | - - | -
507 | -! | -
- substitute(- |
-
508 | -! | -
- expr = dplyr::if_else(- |
-
509 | -! | -
- data$.cooksd > outliers * mean(data$.cooksd, na.rm = TRUE),- |
-
510 | -! | -
- as.character(stats::na.omit(ANL)[[label_var]]),- |
-
511 | -- |
- ""- |
-
512 | -- |
- ) %>%- |
-
513 | -! | -
- dplyr::if_else(is.na(.), "cooksd == NaN", .),- |
-
514 | -! | -
- env = list(outliers = input$outlier, label_var = input$label_var)- |
-
515 | -- |
- )- |
-
516 | -- |
- })- |
-
517 | -- | - - | -
518 | -! | -
- label_min_segment <- reactive({- |
-
519 | -! | -
- input$label_min_segment- |
-
520 | -- |
- })- |
-
521 | -- | - - | -
522 | -! | -
- outlier_label <- reactive({- |
-
523 | -! | -
- substitute(- |
-
524 | -! | -
- expr = ggrepel::geom_text_repel(- |
-
525 | -! | -
- label = label_col,- |
-
526 | -! | -
- color = "red",- |
-
527 | -! | -
- hjust = 0,- |
-
528 | -! | -
- vjust = 1,- |
-
529 | -! | -
- max.overlaps = Inf,- |
-
530 | -! | -
- min.segment.length = label_min_segment,- |
-
531 | -! | -
- segment.alpha = 0.5,- |
-
532 | -! | -
- seed = 123- |
-
533 | -- |
- ),- |
-
534 | -! | -
- env = list(label_col = label_col(), label_min_segment = label_min_segment())- |
-
535 | -- |
- )- |
-
536 | -- |
- })- |
-
537 | -- | - - | -
538 | -! | -
- output_q <- reactive({- |
-
539 | -! | -
- alpha <- input$alpha- |
-
540 | -! | -
- size <- input$size- |
-
541 | -! | -
- ggtheme <- input$ggtheme- |
-
542 | -! | -
- input_type <- input$plot_type- |
-
543 | -! | -
- show_outlier <- input$show_outlier- |
-
544 | -- | - - | -
545 | -! | -
- teal::validate_inputs(iv_r())- |
-
546 | -- | - - | -
547 | -! | -
- plot_type_0 <- function() {- |
-
548 | -! | -
- fit <- fit_r()[["fit"]]- |
-
549 | -! | -
- ANL <- anl_merged_q()[["ANL"]]- |
-
550 | -- | - - | -
551 | -! | -
- stopifnot(ncol(fit$model) == 2)- |
-
552 | -- | - - | -
553 | -! | -
- if (!is.factor(ANL[[regression_var()$regressor]])) {- |
-
554 | -! | -
- shinyjs::show("size")- |
-
555 | -! | -
- shinyjs::show("alpha")- |
-
556 | -! | -
- plot <- substitute(- |
-
557 | -! | -
- env = list(- |
-
558 | -! | -
- regressor = regression_var()$regressor,- |
-
559 | -! | -
- response = regression_var()$response,- |
-
560 | -! | -
- size = size,- |
-
561 | -! | -
- alpha = alpha- |
-
562 | -- |
- ),- |
-
563 | -! | -
- expr = ggplot(- |
-
564 | -! | -
- fit$model[, 2:1],- |
-
565 | -! | -
- aes_string(regressor, response)- |
-
566 | -- |
- ) +- |
-
567 | -! | -
- geom_point(size = size, alpha = alpha) +- |
-
568 | -! | -
- stat_smooth(- |
-
569 | -! | -
- method = "lm",- |
-
570 | -! | -
- formula = y ~ x,- |
-
571 | -! | -
- se = FALSE- |
-
572 | -- |
- )- |
-
573 | -- |
- )- |
-
574 | -! | -
- if (show_outlier) {- |
-
575 | -! | -
- plot <- substitute(- |
-
576 | -! | -
- expr = plot + outlier_label,- |
-
577 | -! | -
- env = list(plot = plot, outlier_label = outlier_label())- |
-
578 | -- |
- )- |
-
579 | -- |
- }- |
-
580 | -- |
- } else {- |
-
581 | -! | -
- shinyjs::hide("size")- |
-
582 | -! | -
- shinyjs::hide("alpha")- |
-
583 | -! | -
- plot <- substitute(- |
-
584 | -! | -
- expr = ggplot(fit$model[, 2:1], aes_string(regressor, response)) +- |
-
585 | -! | -
- geom_boxplot(),- |
-
586 | -! | -
- env = list(regressor = regression_var()$regressor, response = regression_var()$response)- |
-
587 | -- |
- )- |
-
588 | -! | -
- if (show_outlier) {- |
-
589 | -! | -
- plot <- substitute(expr = plot + outlier_label, env = list(plot = plot, outlier_label = outlier_label()))- |
-
590 | -- |
- }- |
-
591 | -- |
- }- |
-
592 | -- | - - | -
593 | -! | -
- parsed_ggplot2_args <- teal.widgets::parse_ggplot2_args(- |
-
594 | -! | -
- teal.widgets::resolve_ggplot2_args(- |
-
595 | -! | -
- user_plot = ggplot2_args[["Response vs Regressor"]],- |
-
596 | -! | -
- user_default = ggplot2_args$default,- |
-
597 | -! | -
- module_plot = teal.widgets::ggplot2_args(- |
-
598 | -! | -
- labs = list(- |
-
599 | -! | -
- title = "Response vs Regressor",- |
-
600 | -! | -
- x = varname_w_label(regression_var()$regressor, ANL),- |
-
601 | -! | -
- y = varname_w_label(regression_var()$response, ANL)- |
-
602 | -- |
- ),- |
-
603 | -! | -
- theme = list()- |
-
604 | -- |
- )- |
-
605 | -- |
- ),- |
-
606 | -! | -
- ggtheme = ggtheme- |
-
607 | -- |
- )- |
-
608 | -- | - - | -
609 | -! | -
- teal.code::eval_code(- |
-
610 | -! | -
- fit_r(),- |
-
611 | -! | -
- substitute(- |
-
612 | -! | -
- expr = {- |
-
613 | -! | -
- class(fit$residuals) <- NULL- |
-
614 | -! | -
- data <- fortify(fit)- |
-
615 | -! | -
- g <- plot- |
-
616 | -! | -
- print(g)- |
-
617 | -- |
- },- |
-
618 | -! | -
- env = list(- |
-
619 | -! | -
- plot = Reduce(function(x, y) call("+", x, y), c(plot, parsed_ggplot2_args))- |
-
620 | -- |
- )- |
-
621 | -- |
- )- |
-
622 | -- |
- )- |
-
623 | -- |
- }- |
-
624 | -- | - - | -
625 | -! | -
- plot_base <- function() {- |
-
626 | -! | -
- base_fit <- fit_r()- |
-
627 | -! | -
- teal.code::eval_code(- |
-
628 | -! | -
- base_fit,- |
-
629 | -! | -
- quote({- |
-
630 | -! | -
- class(fit$residuals) <- NULL- |
-
631 | -- | - - | -
632 | -! | -
- data <- ggplot2::fortify(fit)- |
-
633 | -- | - - | -
634 | -! | -
- smooth <- function(x, y) {- |
-
635 | -! | -
- as.data.frame(stats::lowess(x, y, f = 2 / 3, iter = 3))- |
-
636 | -- |
- }- |
-
637 | -- | - - | -
638 | -! | -
- smoothy_aes <- ggplot2::aes_string(x = "x", y = "y")- |
-
639 | -- | - - | -
640 | -! | -
- reg_form <- deparse(fit$call[[2]])- |
-
641 | -- |
- })- |
-
642 | -- |
- )- |
-
643 | -- |
- }- |
-
644 | -- | - - | -
645 | -! | -
- plot_type_1 <- function(plot_base) {- |
-
646 | -! | -
- shinyjs::show("size")- |
-
647 | -! | -
- shinyjs::show("alpha")- |
-
648 | -! | -
- plot <- substitute(- |
-
649 | -! | -
- expr = ggplot(data = data, aes(.fitted, .resid)) +- |
-
650 | -! | -
- geom_point(size = size, alpha = alpha) +- |
-
651 | -! | -
- geom_hline(yintercept = 0, linetype = "dashed", size = 1) +- |
-
652 | -! | -
- geom_line(data = smoothy, mapping = smoothy_aes),- |
-
653 | -! | -
- env = list(size = size, alpha = alpha)- |
-
654 | -- |
- )- |
-
655 | -! | -
- if (show_outlier) {- |
-
656 | -! | -
- plot <- substitute(expr = plot + outlier_label, env = list(plot = plot, outlier_label = outlier_label()))- |
-
657 | -- |
- }- |
-
658 | -- | - - | -
659 | -! | -
- parsed_ggplot2_args <- teal.widgets::parse_ggplot2_args(- |
-
660 | -! | -
- teal.widgets::resolve_ggplot2_args(- |
-
661 | -! | -
- user_plot = ggplot2_args[["Residuals vs Fitted"]],- |
-
662 | -! | -
- user_default = ggplot2_args$default,- |
-
663 | -! | -
- module_plot = teal.widgets::ggplot2_args(- |
-
664 | -! | -
- labs = list(- |
-
665 | -! | -
- x = quote(paste0("Fitted values\nlm(", reg_form, ")")),- |
-
666 | -! | -
- y = "Residuals",- |
-
667 | -! | -
- title = "Residuals vs Fitted"- |
-
668 | -- |
- )- |
-
669 | -- |
- )- |
-
670 | -- |
- ),- |
-
671 | -! | -
- ggtheme = ggtheme- |
-
672 | -- |
- )- |
-
673 | -- | - - | -
674 | -! | -
- teal.code::eval_code(- |
-
675 | -! | -
- plot_base,- |
-
676 | -! | -
- substitute(- |
-
677 | -! | -
- expr = {- |
-
678 | -! | -
- smoothy <- smooth(data$.fitted, data$.resid)- |
-
679 | -! | -
- g <- plot- |
-
680 | -! | -
- print(g)- |
-
681 | -- |
- },- |
-
682 | -! | -
- env = list(- |
-
683 | -! | -
- plot = Reduce(function(x, y) call("+", x, y), c(plot, parsed_ggplot2_args))- |
-
684 | -- |
- )- |
-
685 | -- |
- )- |
-
686 | -- |
- )- |
-
687 | -- |
- }- |
-
688 | -- | - - | -
689 | -! | -
- plot_type_2 <- function(plot_base) {- |
-
690 | -! | -
- shinyjs::show("size")- |
-
691 | -! | -
- shinyjs::show("alpha")- |
-
692 | -! | -
- plot <- substitute(- |
-
693 | -! | -
- expr = ggplot(data = data, aes(sample = .stdresid)) +- |
-
694 | -! | -
- stat_qq(size = size, alpha = alpha) +- |
-
695 | -! | -
- geom_abline(linetype = "dashed"),- |
-
696 | -! | -
- env = list(size = size, alpha = alpha)- |
-
697 | -- |
- )- |
-
698 | -! | -
- if (show_outlier) {- |
-
699 | -! | -
- plot <- substitute(- |
-
700 | -! | -
- expr = plot +- |
-
701 | -! | -
- stat_qq(- |
-
702 | -! | -
- geom = ggrepel::GeomTextRepel,- |
-
703 | -! | -
- label = label_col %>%- |
-
704 | -! | -
- data.frame(label = .) %>%- |
-
705 | -! | -
- dplyr::filter(label != "cooksd == NaN") %>%- |
-
706 | -! | -
- unlist(),- |
-
707 | -! | -
- color = "red",- |
-
708 | -! | -
- hjust = 0,- |
-
709 | -! | -
- vjust = 0,- |
-
710 | -! | -
- max.overlaps = Inf,- |
-
711 | -! | -
- min.segment.length = label_min_segment,- |
-
712 | -! | -
- segment.alpha = .5,- |
-
713 | -! | -
- seed = 123- |
-
714 | -- |
- ),- |
-
715 | -! | -
- env = list(plot = plot, label_col = label_col(), label_min_segment = label_min_segment())- |
-
716 | -- |
- )- |
-
717 | -- |
- }- |
-
718 | -- | - - | -
719 | -! | -
- parsed_ggplot2_args <- teal.widgets::parse_ggplot2_args(- |
-
720 | -! | -
- teal.widgets::resolve_ggplot2_args(- |
-
721 | -! | -
- user_plot = ggplot2_args[["Normal Q-Q"]],- |
-
722 | -! | -
- user_default = ggplot2_args$default,- |
-
723 | -! | -
- module_plot = teal.widgets::ggplot2_args(- |
-
724 | -! | -
- labs = list(- |
-
725 | -! | -
- x = quote(paste0("Theoretical Quantiles\nlm(", reg_form, ")")),- |
-
726 | -! | -
- y = "Standardized residuals",- |
-
727 | -! | -
- title = "Normal Q-Q"- |
-
728 | -- |
- )- |
-
729 | -- |
- )- |
-
730 | -- |
- ),- |
-
731 | -! | -
- ggtheme = ggtheme- |
-
732 | -- |
- )- |
-
733 | -- | - - | -
734 | -! | -
- teal.code::eval_code(- |
-
735 | -! | -
- plot_base,- |
-
736 | -! | -
- substitute(- |
-
737 | -! | -
- expr = {- |
-
738 | -! | -
- g <- plot- |
-
739 | -! | -
- print(g)- |
-
740 | -- |
- },- |
-
741 | -! | -
- env = list(- |
-
742 | -! | -
- plot = Reduce(function(x, y) call("+", x, y), c(plot, parsed_ggplot2_args))- |
-
743 | -- |
- )- |
-
744 | -- |
- )- |
-
745 | -- |
- )- |
-
746 | -- |
- }- |
-
747 | -- | - - | -
748 | -! | -
- plot_type_3 <- function(plot_base) {- |
-
749 | -! | -
- shinyjs::show("size")- |
-
750 | -! | -
- shinyjs::show("alpha")- |
-
751 | -! | -
- plot <- substitute(- |
-
752 | -! | -
- expr = ggplot(data = data, aes(.fitted, sqrt(abs(.stdresid)))) +- |
-
753 | -! | -
- geom_point(size = size, alpha = alpha) +- |
-
754 | -! | -
- geom_line(data = smoothy, mapping = smoothy_aes),- |
-
755 | -! | -
- env = list(size = size, alpha = alpha)- |
-
756 | -- |
- )- |
-
757 | -! | -
- if (show_outlier) {- |
-
758 | -! | -
- plot <- substitute(expr = plot + outlier_label, env = list(plot = plot, outlier_label = outlier_label()))- |
-
759 | -- |
- }- |
-
760 | -- | - - | -
761 | -! | -
- parsed_ggplot2_args <- teal.widgets::parse_ggplot2_args(- |
-
762 | -! | -
- teal.widgets::resolve_ggplot2_args(- |
-
763 | -! | -
- user_plot = ggplot2_args[["Scale-Location"]],- |
-
764 | -! | -
- user_default = ggplot2_args$default,- |
-
765 | -! | -
- module_plot = teal.widgets::ggplot2_args(- |
-
766 | -! | -
- labs = list(- |
-
767 | -! | -
- x = quote(paste0("Fitted values\nlm(", reg_form, ")")),- |
-
768 | -! | -
- y = quote(expression(sqrt(abs(`Standardized residuals`)))),- |
-
769 | -! | -
- title = "Scale-Location"- |
-
770 | -- |
- )- |
-
771 | -- |
- )- |
-
772 | -- |
- ),- |
-
773 | -! | -
- ggtheme = ggtheme- |
-
774 | -- |
- )- |
-
775 | -- | - - | -
776 | -! | -
- teal.code::eval_code(- |
-
777 | -! | -
- plot_base,- |
-
778 | -! | -
- substitute(- |
-
779 | -! | -
- expr = {- |
-
780 | -! | -
- smoothy <- smooth(data$.fitted, sqrt(abs(data$.stdresid)))- |
-
781 | -! | -
- g <- plot- |
-
782 | -! | -
- print(g)- |
-
783 | -- |
- },- |
-
784 | -! | -
- env = list(- |
-
785 | -! | -
- plot = Reduce(function(x, y) call("+", x, y), c(plot, parsed_ggplot2_args))- |
-
786 | -- |
- )- |
-
787 | -- |
- )- |
-
788 | -- |
- )- |
-
789 | -- |
- }- |
-
790 | -- | - - | -
791 | -! | -
- plot_type_4 <- function(plot_base) {- |
-
792 | -! | -
- shinyjs::hide("size")- |
-
793 | -! | -
- shinyjs::show("alpha")- |
-
794 | -! | -
- plot <- substitute(- |
-
795 | -! | -
- expr = ggplot(data = data, aes(seq_along(.cooksd), .cooksd)) +- |
-
796 | -! | -
- geom_col(alpha = alpha),- |
-
797 | -! | -
- env = list(alpha = alpha)- |
-
798 | -- |
- )- |
-
799 | -! | -
- if (show_outlier) {- |
-
800 | -! | -
- plot <- substitute(- |
-
801 | -! | -
- expr = plot +- |
-
802 | -! | -
- geom_hline(- |
-
803 | -! | -
- yintercept = c(- |
-
804 | -! | -
- outlier * mean(data$.cooksd, na.rm = TRUE),- |
-
805 | -! | -
- mean(data$.cooksd, na.rm = TRUE)- |
-
806 | -- |
- ),- |
-
807 | -! | -
- color = "red",- |
-
808 | -! | -
- linetype = "dashed"- |
-
809 | -- |
- ) +- |
-
810 | -! | -
- geom_text(- |
-
811 | -! | -
- aes(- |
-
812 | -! | -
- x = 0,- |
-
813 | -! | -
- y = mean(data$.cooksd, na.rm = TRUE),- |
-
814 | -! | -
- label = paste("mu", "=", round(mean(data$.cooksd, na.rm = TRUE), 4)),- |
-
815 | -! | -
- vjust = -1,- |
-
816 | -! | -
- hjust = 0,- |
-
817 | -! | -
- color = "red",- |
-
818 | -! | -
- angle = 90- |
-
819 | -- |
- ),- |
-
820 | -! | -
- parse = TRUE,- |
-
821 | -! | -
- show.legend = FALSE- |
-
822 | -- |
- ) +- |
-
823 | -! | -
- outlier_label,- |
-
824 | -! | -
- env = list(plot = plot, outlier = input$outlier, outlier_label = outlier_label())- |
-
825 | -- |
- )- |
-
826 | -- |
- }- |
-
827 | -- | - - | -
828 | -! | -
- parsed_ggplot2_args <- teal.widgets::parse_ggplot2_args(- |
-
829 | -! | -
- teal.widgets::resolve_ggplot2_args(- |
-
830 | -! | -
- user_plot = ggplot2_args[["Cook's distance"]],- |
-
831 | -! | -
- user_default = ggplot2_args$default,- |
-
832 | -! | -
- module_plot = teal.widgets::ggplot2_args(- |
-
833 | -! | -
- labs = list(- |
-
834 | -! | -
- x = quote(paste0("Obs. number\nlm(", reg_form, ")")),- |
-
835 | -! | -
- y = "Cook's distance",- |
-
836 | -! | -
- title = "Cook's distance"- |
-
837 | -- |
- )- |
-
838 | -- |
- )- |
-
839 | -- |
- ),- |
-
840 | -! | -
- ggtheme = ggtheme- |
-
841 | -- |
- )- |
-
842 | -- | - - | -
843 | -! | -
- teal.code::eval_code(- |
-
844 | -! | -
- plot_base,- |
-
845 | -! | -
- substitute(- |
-
846 | -! | -
- expr = {- |
-
847 | -! | -
- g <- plot- |
-
848 | -! | -
- print(g)- |
-
849 | -- |
- },- |
-
850 | -! | -
- env = list(- |
-
851 | -! | -
- plot = Reduce(function(x, y) call("+", x, y), c(plot, parsed_ggplot2_args))- |
-
852 | -- |
- )- |
-
853 | -- |
- )- |
-
854 | -- |
- )- |
-
855 | -- |
- }- |
-
856 | -- | - - | -
857 | -- | - - | -
858 | -! | -
- plot_type_5 <- function(plot_base) {- |
-
859 | -! | -
- shinyjs::show("size")- |
-
860 | -! | -
- shinyjs::show("alpha")- |
-
861 | -! | -
- plot <- substitute(- |
-
862 | -! | -
- expr = ggplot(data = data, aes(.hat, .stdresid)) +- |
-
863 | -! | -
- geom_vline(- |
-
864 | -! | -
- size = 1,- |
-
865 | -! | -
- colour = "black",- |
-
866 | -! | -
- linetype = "dashed",- |
-
867 | -! | -
- xintercept = 0- |
-
868 | -- |
- ) +- |
-
869 | -! | -
- geom_hline(- |
-
870 | -! | -
- size = 1,- |
-
871 | -! | -
- colour = "black",- |
-
872 | -! | -
- linetype = "dashed",- |
-
873 | -! | -
- yintercept = 0- |
-
874 | -- |
- ) +- |
-
875 | -! | -
- geom_point(size = size, alpha = alpha) +- |
-
876 | -! | -
- geom_line(data = smoothy, mapping = smoothy_aes),- |
-
877 | -! | -
- env = list(size = size, alpha = alpha)- |
-
878 | -- |
- )- |
-
879 | -! | -
- if (show_outlier) {- |
-
880 | -! | -
- plot <- substitute(expr = plot + outlier_label, env = list(plot = plot, outlier_label = outlier_label()))- |
-
881 | -- |
- }- |
-
882 | -- | - - | -
883 | -! | -
- parsed_ggplot2_args <- teal.widgets::parse_ggplot2_args(- |
-
884 | -! | -
- teal.widgets::resolve_ggplot2_args(- |
-
885 | -! | -
- user_plot = ggplot2_args[["Residuals vs Leverage"]],- |
-
886 | -! | -
- user_default = ggplot2_args$default,- |
-
887 | -! | -
- module_plot = teal.widgets::ggplot2_args(- |
-
888 | -! | -
- labs = list(- |
-
889 | -! | -
- x = quote(paste0("Standardized residuals\nlm(", reg_form, ")")),- |
-
890 | -! | -
- y = "Leverage",- |
-
891 | -! | -
- title = "Residuals vs Leverage"- |
-
892 | -- |
- )- |
-
893 | -- |
- )- |
-
894 | -- |
- ),- |
-
895 | -! | -
- ggtheme = ggtheme- |
-
896 | -- |
- )- |
-
897 | -- | - - | -
898 | -! | -
- teal.code::eval_code(- |
-
899 | -! | -
- plot_base,- |
-
900 | -! | -
- substitute(- |
-
901 | -! | -
- expr = {- |
-
902 | -! | -
- smoothy <- smooth(data$.hat, data$.stdresid)- |
-
903 | -! | -
- g <- plot- |
-
904 | -! | -
- print(g)- |
-
905 | -- |
- },- |
-
906 | -! | -
- env = list(- |
-
907 | -! | -
- plot = Reduce(function(x, y) call("+", x, y), c(plot, parsed_ggplot2_args))- |
-
908 | -- |
- )- |
-
909 | -- |
- )- |
-
910 | -- |
- )- |
-
911 | -- |
- }- |
-
912 | -- | - - | -
913 | -! | -
- plot_type_6 <- function(plot_base) {- |
-
914 | -! | -
- shinyjs::show("size")- |
-
915 | -! | -
- shinyjs::show("alpha")- |
-
916 | -! | -
- plot <- substitute(- |
-
917 | -! | -
- expr = ggplot(data = data, aes(.hat, .cooksd)) +- |
-
918 | -! | -
- geom_vline(xintercept = 0, colour = NA) +- |
-
919 | -! | -
- geom_abline(- |
-
920 | -! | -
- slope = seq(0, 3, by = 0.5),- |
-
921 | -! | -
- colour = "black",- |
-
922 | -! | -
- linetype = "dashed",- |
-
923 | -! | -
- size = 1- |
-
924 | -- |
- ) +- |
-
925 | -! | -
- geom_line(data = smoothy, mapping = smoothy_aes) +- |
-
926 | -! | -
- geom_point(size = size, alpha = alpha),- |
-
927 | -! | -
- env = list(size = size, alpha = alpha)- |
-
928 | -- |
- )- |
-
929 | -! | -
- if (show_outlier) {- |
-
930 | -! | -
- plot <- substitute(expr = plot + outlier_label, env = list(plot = plot, outlier_label = outlier_label()))- |
-
931 | -- |
- }- |
-
932 | -- | - - | -
933 | -! | -
- parsed_ggplot2_args <- teal.widgets::parse_ggplot2_args(- |
-
934 | -! | -
- teal.widgets::resolve_ggplot2_args(- |
-
935 | -! | -
- user_plot = ggplot2_args[["Cook's dist vs Leverage"]],- |
-
936 | -! | -
- user_default = ggplot2_args$default,- |
-
937 | -! | -
- module_plot = teal.widgets::ggplot2_args(- |
-
938 | -! | -
- labs = list(- |
-
939 | -! | -
- x = quote(paste0("Leverage\nlm(", reg_form, ")")),- |
-
940 | -! | -
- y = "Cooks's distance",- |
-
941 | -! | -
- title = "Cook's dist vs Leverage"- |
-
942 | -- |
- )- |
-
943 | -- |
- )- |
-
944 | -- |
- ),- |
-
945 | -! | -
- ggtheme = ggtheme- |
-
946 | -- |
- )- |
-
947 | -- | - - | -
948 | -! | -
- teal.code::eval_code(- |
-
949 | -! | -
- plot_base,- |
-
950 | -! | -
- substitute(- |
-
951 | -! | -
- expr = {- |
-
952 | -! | -
- smoothy <- smooth(data$.hat, data$.cooksd)- |
-
953 | -! | -
- g <- plot- |
-
954 | -! | -
- print(g)- |
-
955 | -- |
- },- |
-
956 | -! | -
- env = list(- |
-
957 | -! | -
- plot = Reduce(function(x, y) call("+", x, y), c(plot, parsed_ggplot2_args))- |
-
958 | -- |
- )- |
-
959 | -- |
- )- |
-
960 | -- |
- )- |
-
961 | -- |
- }- |
-
962 | -- | - - | -
963 | -! | -
- qenv <- if (input_type == "Response vs Regressor") {- |
-
964 | -! | -
- plot_type_0()- |
-
965 | -- |
- } else {- |
-
966 | -! | -
- plot_base_q <- plot_base()- |
-
967 | -! | -
- switch(input_type,- |
-
968 | -! | -
- "Residuals vs Fitted" = plot_base_q %>% plot_type_1(),- |
-
969 | -! | -
- "Normal Q-Q" = plot_base_q %>% plot_type_2(),- |
-
970 | -! | -
- "Scale-Location" = plot_base_q %>% plot_type_3(),- |
-
971 | -! | -
- "Cook's distance" = plot_base_q %>% plot_type_4(),- |
-
972 | -! | -
- "Residuals vs Leverage" = plot_base_q %>% plot_type_5(),- |
-
973 | -! | -
- "Cook's dist vs Leverage" = plot_base_q %>% plot_type_6()- |
-
974 | -- |
- )- |
-
975 | -- |
- }- |
-
976 | -! | -
- qenv- |
-
977 | -- |
- })- |
-
978 | -- | - - | -
979 | -- | - - | -
980 | -! | -
- fitted <- reactive(output_q()[["fit"]])- |
-
981 | -! | -
- plot_r <- reactive(output_q()[["g"]])- |
-
982 | -- | - - | -
983 | -- |
- # Insert the plot into a plot_with_settings module from teal.widgets- |
-
984 | -! | -
- pws <- teal.widgets::plot_with_settings_srv(- |
-
985 | -! | -
- id = "myplot",- |
-
986 | -! | -
- plot_r = plot_r,- |
-
987 | -! | -
- height = plot_height,- |
-
988 | -! | -
- width = plot_width- |
-
989 | -- |
- )- |
-
990 | -- | - - | -
991 | -! | -
- output$text <- renderText({- |
-
992 | -! | -
- req(iv_r()$is_valid())- |
-
993 | -! | -
- req(iv_out$is_valid())- |
-
994 | -! | -
- paste(utils::capture.output(summary(teal.code::dev_suppress(fitted())))[-1],- |
-
995 | -! | -
- collapse = "\n"- |
-
996 | -- |
- )- |
-
997 | -- |
- })- |
-
998 | -- | - - | -
999 | -! | -
- teal.widgets::verbatim_popup_srv(- |
-
1000 | -! | -
- id = "warning",- |
-
1001 | -! | -
- verbatim_content = reactive(teal.code::get_warnings(output_q())),- |
-
1002 | -! | -
- title = "Warning",- |
-
1003 | -! | -
- disabled = reactive(is.null(teal.code::get_warnings(output_q())))- |
-
1004 | -- |
- )- |
-
1005 | -- | - - | -
1006 | -! | -
- teal.widgets::verbatim_popup_srv(- |
-
1007 | -! | -
- id = "rcode",- |
-
1008 | -! | -
- verbatim_content = reactive(teal.code::get_code(output_q())),- |
-
1009 | -! | -
- title = "R code for the regression plot",- |
-
1010 | -- |
- )- |
-
1011 | -- | - - | -
1012 | -- |
- ### REPORTER- |
-
1013 | -! | -
- if (with_reporter) {- |
-
1014 | -! | -
- card_fun <- function(comment, label) {- |
-
1015 | -! | -
- card <- teal::report_card_template(- |
-
1016 | -! | -
- title = "Linear Regression Plot",- |
-
1017 | -! | -
- label = label,- |
-
1018 | -! | -
- with_filter = with_filter,- |
-
1019 | -! | -
- filter_panel_api = filter_panel_api- |
-
1020 | -- |
- )- |
-
1021 | -! | -
- card$append_text("Plot", "header3")- |
-
1022 | -! | -
- card$append_plot(plot_r(), dim = pws$dim())- |
-
1023 | -! | -
- if (!comment == "") {- |
-
1024 | -! | -
- card$append_text("Comment", "header3")- |
-
1025 | -! | -
- card$append_text(comment)- |
-
1026 | -- |
- }- |
-
1027 | -! | -
- card$append_src(teal.code::get_code(output_q()))- |
-
1028 | -! | -
- card- |
-
1029 | -- |
- }- |
-
1030 | -! | -
- teal.reporter::simple_reporter_srv("simple_reporter", reporter = reporter, card_fun = card_fun)- |
-
1031 | -- |
- }- |
-
1032 | -- |
- ###- |
-
1033 | -- |
- })- |
-
1034 | -- |
- }- |
-
1035 | -- | - - | -
1036 | -- |
- regression_names <- paste0(- |
-
1037 | -- |
- '"Response vs Regressor", "Residuals vs Fitted", ',- |
-
1038 | -- |
- '"Scale-Location", "Cook\'s distance", "Residuals vs Leverage"", "Cook\'s dist vs Leverage"'- |
-
1039 | -- |
- )- |
-
1 | -- |
- #' `teal` module: Stack plots of variables and show association with reference variable- |
-
2 | -- |
- #'- |
-
3 | -- |
- #' Module provides functionality for visualizing the distribution of variables and- |
-
4 | -- |
- #' their association with a reference variable.- |
-
5 | -- |
- #' It supports configuring the appearance of the plots, including themes and whether to show associations.- |
-
6 | -- |
- #'- |
-
7 | -- |
- #'- |
-
8 | -- |
- #' @note For more examples, please see the vignette "Using association plot" via- |
-
9 | -- |
- #' `vignette("using-association-plot", package = "teal.modules.general")`.- |
-
10 | -- |
- #'- |
-
11 | -- |
- #' @inheritParams teal::module- |
-
12 | -- |
- #' @inheritParams shared_params- |
-
13 | -- |
- #' @param ref (`data_extract_spec` or `list` of multiple `data_extract_spec`)- |
-
14 | -- |
- #' Reference variable, must accepts a `data_extract_spec` with `select_spec(multiple = FALSE)`- |
-
15 | -- |
- #' to ensure single selection option.- |
-
16 | -- |
- #' @param vars (`data_extract_spec` or `list` of multiple `data_extract_spec`)- |
-
17 | -- |
- #' Variables to be associated with the reference variable.- |
-
18 | -- |
- #' @param show_association (`logical`) optional, whether show association of `vars`- |
-
19 | -- |
- #' with reference variable. Defaults to `TRUE`.- |
-
20 | -- |
- #' @param distribution_theme,association_theme (`character`) optional, `ggplot2` themes to be used by default.- |
-
21 | -- |
- #' Default to `"gray"`.- |
-
22 | -- |
- #'- |
-
23 | -- |
- #' @templateVar ggnames "Bivariate1", "Bivariate2"- |
-
24 | -- |
- #' @template ggplot2_args_multi- |
-
25 | -- |
- #'- |
-
26 | -- |
- #' @inherit shared_params return- |
-
27 | -- |
- #'- |
-
28 | -- |
- #' @examples- |
-
29 | -- |
- #' library(teal.widgets)- |
-
30 | -- |
- #'- |
-
31 | -- |
- #' # general data example- |
-
32 | -- |
- #' data <- teal_data()- |
-
33 | -- |
- #' data <- within(data, {- |
-
34 | -- |
- #' require(nestcolor)- |
-
35 | -- |
- #' CO2 <- CO2- |
-
36 | -- |
- #' factors <- names(Filter(isTRUE, vapply(CO2, is.factor, logical(1L))))- |
-
37 | -- |
- #' CO2[factors] <- lapply(CO2[factors], as.character)- |
-
38 | -- |
- #' })- |
-
39 | -- |
- #' datanames(data) <- c("CO2")- |
-
40 | -- |
- #'- |
-
41 | -- |
- #' app <- init(- |
-
42 | -- |
- #' data = data,- |
-
43 | -- |
- #' modules = modules(- |
-
44 | -- |
- #' tm_g_association(- |
-
45 | -- |
- #' ref = data_extract_spec(- |
-
46 | -- |
- #' dataname = "CO2",- |
-
47 | -- |
- #' select = select_spec(- |
-
48 | -- |
- #' label = "Select variable:",- |
-
49 | -- |
- #' choices = variable_choices(data[["CO2"]], c("Plant", "Type", "Treatment")),- |
-
50 | -- |
- #' selected = "Plant",- |
-
51 | -- |
- #' fixed = FALSE- |
-
52 | -- |
- #' )- |
-
53 | -- |
- #' ),- |
-
54 | -- |
- #' vars = data_extract_spec(- |
-
55 | -- |
- #' dataname = "CO2",- |
-
56 | -- |
- #' select = select_spec(- |
-
57 | -- |
- #' label = "Select variables:",- |
-
58 | -- |
- #' choices = variable_choices(data[["CO2"]], c("Plant", "Type", "Treatment")),- |
-
59 | -- |
- #' selected = "Treatment",- |
-
60 | -- |
- #' multiple = TRUE,- |
-
61 | -- |
- #' fixed = FALSE- |
-
62 | -- |
- #' )- |
-
63 | -- |
- #' ),- |
-
64 | -- |
- #' ggplot2_args = ggplot2_args(- |
-
65 | -- |
- #' labs = list(subtitle = "Plot generated by Association Module")- |
-
66 | -- |
- #' )- |
-
67 | -- |
- #' )- |
-
68 | -- |
- #' )- |
-
69 | -- |
- #' )- |
-
70 | -- |
- #' if (interactive()) {- |
-
71 | -- |
- #' shinyApp(app$ui, app$server)- |
-
72 | -- |
- #' }- |
-
73 | -- |
- #'- |
-
74 | -- |
- #' # CDISC data example- |
-
75 | -- |
- #' data <- teal_data()- |
-
76 | -- |
- #' data <- within(data, {- |
-
77 | -- |
- #' require(nestcolor)- |
-
78 | -- |
- #' ADSL <- rADSL- |
-
79 | -- |
- #' })- |
-
80 | -- |
- #' datanames(data) <- "ADSL"- |
-
81 | -- |
- #' join_keys(data) <- default_cdisc_join_keys[datanames(data)]- |
-
82 | -- |
- #'- |
-
83 | -- |
- #' app <- init(- |
-
84 | -- |
- #' data = data,- |
-
85 | -- |
- #' modules = modules(- |
-
86 | -- |
- #' tm_g_association(- |
-
87 | -- |
- #' ref = data_extract_spec(- |
-
88 | -- |
- #' dataname = "ADSL",- |
-
89 | -- |
- #' select = select_spec(- |
-
90 | -- |
- #' label = "Select variable:",- |
-
91 | -- |
- #' choices = variable_choices(- |
-
92 | -- |
- #' data[["ADSL"]],- |
-
93 | -- |
- #' c("SEX", "RACE", "COUNTRY", "ARM", "STRATA1", "STRATA2", "ITTFL", "BMRKR2")- |
-
94 | -- |
- #' ),- |
-
95 | -- |
- #' selected = "RACE",- |
-
96 | -- |
- #' fixed = FALSE- |
-
97 | -- |
- #' )- |
-
98 | -- |
- #' ),- |
-
99 | -- |
- #' vars = data_extract_spec(- |
-
100 | -- |
- #' dataname = "ADSL",- |
-
101 | -- |
- #' select = select_spec(- |
-
102 | -- |
- #' label = "Select variables:",- |
-
103 | -- |
- #' choices = variable_choices(- |
-
104 | -- |
- #' data[["ADSL"]],- |
-
105 | -- |
- #' c("SEX", "RACE", "COUNTRY", "ARM", "STRATA1", "STRATA2", "ITTFL", "BMRKR2")- |
-
106 | -- |
- #' ),- |
-
107 | -- |
- #' selected = "BMRKR2",- |
-
108 | -- |
- #' multiple = TRUE,- |
-
109 | -- |
- #' fixed = FALSE- |
-
110 | -- |
- #' )- |
-
111 | -- |
- #' ),- |
-
112 | -- |
- #' ggplot2_args = ggplot2_args(- |
-
113 | -- |
- #' labs = list(subtitle = "Plot generated by Association Module")- |
-
114 | -- |
- #' )- |
-
115 | -- |
- #' )- |
-
116 | -- |
- #' )- |
-
117 | -- |
- #' )- |
-
118 | -- |
- #' if (interactive()) {- |
-
119 | -- |
- #' shinyApp(app$ui, app$server)- |
-
120 | -- |
- #' }- |
-
121 | -- |
- #'- |
-
122 | -- |
- #' @export- |
-
123 | -- |
- #'- |
-
124 | -- |
- tm_g_association <- function(label = "Association",- |
-
125 | -- |
- ref,- |
-
126 | -- |
- vars,- |
-
127 | -- |
- show_association = TRUE,- |
-
128 | -- |
- plot_height = c(600, 400, 5000),- |
-
129 | -- |
- plot_width = NULL,- |
-
130 | -- |
- distribution_theme = c("gray", "bw", "linedraw", "light", "dark", "minimal", "classic", "void"), # nolint: line_length.- |
-
131 | -- |
- association_theme = c("gray", "bw", "linedraw", "light", "dark", "minimal", "classic", "void"), # nolint: line_length.- |
-
132 | -- |
- pre_output = NULL,- |
-
133 | -- |
- post_output = NULL,- |
-
134 | -- |
- ggplot2_args = teal.widgets::ggplot2_args()) {- |
-
135 | -! | -
- logger::log_info("Initializing tm_g_association")- |
-
136 | -- | - - | -
137 | -- |
- # Normalize the parameters- |
-
138 | -! | -
- if (inherits(ref, "data_extract_spec")) ref <- list(ref)- |
-
139 | -! | -
- if (inherits(vars, "data_extract_spec")) vars <- list(vars)- |
-
140 | -! | -
- if (inherits(ggplot2_args, "ggplot2_args")) ggplot2_args <- list(default = ggplot2_args)- |
-
141 | -- | - - | -
142 | -- |
- # Start of assertions- |
-
143 | -! | -
- checkmate::assert_string(label)- |
-
144 | -- | - - | -
145 | -! | -
- checkmate::assert_list(ref, types = "data_extract_spec")- |
-
146 | -! | -
- if (!all(vapply(ref, function(x) !x$select$multiple, logical(1)))) {- |
-
147 | -! | -
- stop("'ref' should not allow multiple selection")- |
-
148 | -- |
- }- |
-
149 | -- | - - | -
150 | -! | -
- checkmate::assert_list(vars, types = "data_extract_spec")- |
-
151 | -! | -
- checkmate::assert_flag(show_association)- |
-
152 | -- | - - | -
153 | -! | -
- checkmate::assert_numeric(plot_height, len = 3, any.missing = FALSE, finite = TRUE)- |
-
154 | -! | -
- checkmate::assert_numeric(plot_height[1], lower = plot_height[2], upper = plot_height[3], .var.name = "plot_height")- |
-
155 | -! | -
- checkmate::assert_numeric(plot_width, len = 3, any.missing = FALSE, null.ok = TRUE, finite = TRUE)- |
-
156 | -! | -
- checkmate::assert_numeric(- |
-
157 | -! | -
- plot_width[1],- |
-
158 | -! | -
- lower = plot_width[2], upper = plot_width[3], null.ok = TRUE, .var.name = "plot_width"- |
-
159 | -- |
- )- |
-
160 | -- | - - | -
161 | -! | -
- distribution_theme <- match.arg(distribution_theme)- |
-
162 | -! | -
- association_theme <- match.arg(association_theme)- |
-
163 | -- | - - | -
164 | -! | -
- checkmate::assert_multi_class(pre_output, c("shiny.tag", "shiny.tag.list", "html"), null.ok = TRUE)- |
-
165 | -! | -
- checkmate::assert_multi_class(post_output, c("shiny.tag", "shiny.tag.list", "html"), null.ok = TRUE)- |
-
166 | -- | - - | -
167 | -! | -
- plot_choices <- c("Bivariate1", "Bivariate2")- |
-
168 | -! | -
- checkmate::assert_list(ggplot2_args, types = "ggplot2_args")- |
-
169 | -! | -
- checkmate::assert_subset(names(ggplot2_args), c("default", plot_choices))- |
-
170 | -- |
- # End of assertions- |
-
171 | -- | - - | -
172 | -- |
- # Make UI args- |
-
173 | -! | -
- args <- as.list(environment())- |
-
174 | -- | - - | -
175 | -! | -
- data_extract_list <- list(- |
-
176 | -! | -
- ref = ref,- |
-
177 | -! | -
- vars = vars- |
-
178 | -- |
- )- |
-
179 | -- | - - | -
180 | -! | -
- module(- |
-
181 | -! | -
- label = label,- |
-
182 | -! | -
- server = srv_tm_g_association,- |
-
183 | -! | -
- ui = ui_tm_g_association,- |
-
184 | -! | -
- ui_args = args,- |
-
185 | -! | -
- server_args = c(- |
-
186 | -! | -
- data_extract_list,- |
-
187 | -! | -
- list(plot_height = plot_height, plot_width = plot_width, ggplot2_args = ggplot2_args)- |
-
188 | -- |
- ),- |
-
189 | -! | -
- datanames = teal.transform::get_extract_datanames(data_extract_list)- |
-
190 | -- |
- )- |
-
191 | -- |
- }- |
-
192 | -- | - - | -
193 | -- |
- # UI function for the association module- |
-
194 | -- |
- ui_tm_g_association <- function(id, ...) {- |
-
195 | -! | -
- ns <- NS(id)- |
-
196 | -! | -
- args <- list(...)- |
-
197 | -! | -
- is_single_dataset_value <- teal.transform::is_single_dataset(args$ref, args$vars)- |
-
198 | -- | - - | -
199 | -! | -
- teal.widgets::standard_layout(- |
-
200 | -! | -
- output = teal.widgets::white_small_well(- |
-
201 | -! | -
- textOutput(ns("title")),- |
-
202 | -! | -
- tags$br(),- |
-
203 | -! | -
- teal.widgets::plot_with_settings_ui(id = ns("myplot"))- |
-
204 | -- |
- ),- |
-
205 | -! | -
- encoding = div(- |
-
206 | -- |
- ### Reporter- |
-
207 | -! | -
- teal.reporter::simple_reporter_ui(ns("simple_reporter")),- |
-
208 | -- |
- ###- |
-
209 | -! | -
- tags$label("Encodings", class = "text-primary"),- |
-
210 | -! | -
- teal.transform::datanames_input(args[c("ref", "vars")]),- |
-
211 | -! | -
- teal.transform::data_extract_ui(- |
-
212 | -! | -
- id = ns("ref"),- |
-
213 | -! | -
- label = "Reference variable",- |
-
214 | -! | -
- data_extract_spec = args$ref,- |
-
215 | -! | -
- is_single_dataset = is_single_dataset_value- |
-
216 | -- |
- ),- |
-
217 | -! | -
- teal.transform::data_extract_ui(- |
-
218 | -! | -
- id = ns("vars"),- |
-
219 | -! | -
- label = "Associated variables",- |
-
220 | -! | -
- data_extract_spec = args$vars,- |
-
221 | -! | -
- is_single_dataset = is_single_dataset_value- |
-
222 | -- |
- ),- |
-
223 | -! | -
- checkboxInput(- |
-
224 | -! | -
- ns("association"),- |
-
225 | -! | -
- "Association with reference variable",- |
-
226 | -! | -
- value = args$show_association- |
-
227 | -- |
- ),- |
-
228 | -! | -
- checkboxInput(- |
-
229 | -! | -
- ns("show_dist"),- |
-
230 | -! | -
- "Scaled frequencies",- |
-
231 | -! | -
- value = FALSE- |
-
232 | -- |
- ),- |
-
233 | -! | -
- checkboxInput(- |
-
234 | -! | -
- ns("log_transformation"),- |
-
235 | -! | -
- "Log transformed",- |
-
236 | -! | -
- value = FALSE- |
-
237 | -- |
- ),- |
-
238 | -! | -
- teal.widgets::panel_group(- |
-
239 | -! | -
- teal.widgets::panel_item(- |
-
240 | -! | -
- title = "Plot settings",- |
-
241 | -! | -
- teal.widgets::optionalSliderInputValMinMax(ns("alpha"), "Scatterplot opacity:", c(0.5, 0, 1), ticks = FALSE),- |
-
242 | -! | -
- teal.widgets::optionalSliderInputValMinMax(ns("size"), "Scatterplot points size:", c(2, 1, 8), ticks = FALSE),- |
-
243 | -! | -
- checkboxInput(ns("swap_axes"), "Swap axes", value = FALSE),- |
-
244 | -! | -
- checkboxInput(ns("rotate_xaxis_labels"), "Rotate X axis labels", value = FALSE),- |
-
245 | -! | -
- selectInput(- |
-
246 | -! | -
- inputId = ns("distribution_theme"),- |
-
247 | -! | -
- label = "Distribution theme (by ggplot):",- |
-
248 | -! | -
- choices = ggplot_themes,- |
-
249 | -! | -
- selected = args$distribution_theme,- |
-
250 | -! | -
- multiple = FALSE- |
-
251 | -- |
- ),- |
-
252 | -! | -
- selectInput(- |
-
253 | -! | -
- inputId = ns("association_theme"),- |
-
254 | -! | -
- label = "Association theme (by ggplot):",- |
-
255 | -! | -
- choices = ggplot_themes,- |
-
256 | -! | -
- selected = args$association_theme,- |
-
257 | -! | -
- multiple = FALSE- |
-
258 | -- |
- )- |
-
259 | -- |
- )- |
-
260 | -- |
- )- |
-
261 | -- |
- ),- |
-
262 | -! | -
- forms = tagList(- |
-
263 | -! | -
- teal.widgets::verbatim_popup_ui(ns("warning"), "Show Warnings"),- |
-
264 | -! | -
- teal.widgets::verbatim_popup_ui(ns("rcode"), "Show R code")- |
-
265 | -- |
- ),- |
-
266 | -! | -
- pre_output = args$pre_output,- |
-
267 | -! | -
- post_output = args$post_output- |
-
268 | -- |
- )- |
-
269 | -- |
- }- |
-
270 | -- | - - | -
271 | -- |
- # Server function for the association module- |
-
272 | -- |
- srv_tm_g_association <- function(id,- |
-
273 | -- |
- data,- |
-
274 | -- |
- reporter,- |
-
275 | -- |
- filter_panel_api,- |
-
276 | -- |
- ref,- |
-
277 | -- |
- vars,- |
-
278 | -- |
- plot_height,- |
-
279 | -- |
- plot_width,- |
-
280 | -- |
- ggplot2_args) {- |
-
281 | -! | -
- with_reporter <- !missing(reporter) && inherits(reporter, "Reporter")- |
-
282 | -! | -
- with_filter <- !missing(filter_panel_api) && inherits(filter_panel_api, "FilterPanelAPI")- |
-
283 | -! | -
- checkmate::assert_class(data, "reactive")- |
-
284 | -! | -
- checkmate::assert_class(isolate(data()), "teal_data")- |
-
285 | -- | - - | -
286 | -! | -
- moduleServer(id, function(input, output, session) {- |
-
287 | -! | -
- selector_list <- teal.transform::data_extract_multiple_srv(- |
-
288 | -! | -
- data_extract = list(ref = ref, vars = vars),- |
-
289 | -! | -
- datasets = data,- |
-
290 | -! | -
- select_validation_rule = list(- |
-
291 | -! | -
- ref = shinyvalidate::compose_rules(- |
-
292 | -! | -
- shinyvalidate::sv_required("A reference variable needs to be selected."),- |
-
293 | -! | -
- ~ if ((.) %in% selector_list()$vars()$select) {- |
-
294 | -! | -
- "Associated variables and reference variable cannot overlap"- |
-
295 | -- |
- }- |
-
296 | -- |
- ),- |
-
297 | -! | -
- vars = shinyvalidate::compose_rules(- |
-
298 | -! | -
- shinyvalidate::sv_required("An associated variable needs to be selected."),- |
-
299 | -! | -
- ~ if (length(selector_list()$ref()$select) != 0 && selector_list()$ref()$select %in% (.)) {- |
-
300 | -! | -
- "Associated variables and reference variable cannot overlap"- |
-
301 | -- |
- }- |
-
302 | -- |
- )- |
-
303 | -- |
- )- |
-
304 | -- |
- )- |
-
305 | -- | - - | -
306 | -! | -
- iv_r <- reactive({- |
-
307 | -! | -
- iv <- shinyvalidate::InputValidator$new()- |
-
308 | -! | -
- teal.transform::compose_and_enable_validators(iv, selector_list)- |
-
309 | -- |
- })- |
-
310 | -- | - - | -
311 | -! | -
- anl_merged_input <- teal.transform::merge_expression_srv(- |
-
312 | -! | -
- datasets = data,- |
-
313 | -! | -
- selector_list = selector_list- |
-
314 | -- |
- )- |
-
315 | -- | - - | -
316 | -! | -
- anl_merged_q <- reactive({- |
-
317 | -! | -
- req(anl_merged_input())- |
-
318 | -! | -
- data() %>% teal.code::eval_code(as.expression(anl_merged_input()$expr))- |
-
319 | -- |
- })- |
-
320 | -- | - - | -
321 | -! | -
- merged <- list(- |
-
322 | -! | -
- anl_input_r = anl_merged_input,- |
-
323 | -! | -
- anl_q_r = anl_merged_q- |
-
324 | -- |
- )- |
-
325 | -- | - - | -
326 | -! | -
- output_q <- reactive({- |
-
327 | -! | -
- teal::validate_inputs(iv_r())- |
-
328 | -- | - - | -
329 | -! | -
- ANL <- merged$anl_q_r()[["ANL"]]- |
-
330 | -! | -
- teal::validate_has_data(ANL, 3)- |
-
331 | -- | - - | -
332 | -! | -
- vars_names <- merged$anl_input_r()$columns_source$vars- |
-
333 | -- | - - | -
334 | -! | -
- ref_name <- as.vector(merged$anl_input_r()$columns_source$ref)- |
-
335 | -! | -
- association <- input$association- |
-
336 | -! | -
- show_dist <- input$show_dist- |
-
337 | -! | -
- log_transformation <- input$log_transformation- |
-
338 | -! | -
- rotate_xaxis_labels <- input$rotate_xaxis_labels- |
-
339 | -! | -
- swap_axes <- input$swap_axes- |
-
340 | -! | -
- distribution_theme <- input$distribution_theme- |
-
341 | -! | -
- association_theme <- input$association_theme- |
-
342 | -- | - - | -
343 | -! | -
- is_scatterplot <- is.numeric(ANL[[ref_name]]) && any(vapply(ANL[vars_names], is.numeric, logical(1)))- |
-
344 | -! | -
- if (is_scatterplot) {- |
-
345 | -! | -
- shinyjs::show("alpha")- |
-
346 | -! | -
- shinyjs::show("size")- |
-
347 | -! | -
- alpha <- input$alpha- |
-
348 | -! | -
- size <- input$size- |
-
349 | -- |
- } else {- |
-
350 | -! | -
- shinyjs::hide("alpha")- |
-
351 | -! | -
- shinyjs::hide("size")- |
-
352 | -! | -
- alpha <- 0.5- |
-
353 | -! | -
- size <- 2- |
-
354 | -- |
- }- |
-
355 | -- | - - | -
356 | -! | -
- teal::validate_has_data(ANL[, c(ref_name, vars_names)], 3, complete = TRUE, allow_inf = FALSE)- |
-
357 | -- | - - | -
358 | -- |
- # reference- |
-
359 | -! | -
- ref_class <- class(ANL[[ref_name]])[1]- |
-
360 | -! | -
- if (is.numeric(ANL[[ref_name]]) && log_transformation) {- |
-
361 | -- |
- # works for both integers and doubles- |
-
362 | -! | -
- ref_cl_name <- call("log", as.name(ref_name))- |
-
363 | -! | -
- ref_cl_lbl <- varname_w_label(ref_name, ANL, prefix = "Log of ")- |
-
364 | -- |
- } else {- |
-
365 | -- |
- # silently ignore when non-numeric even if `log` is selected because some- |
-
366 | -- |
- # variables may be numeric and others not- |
-
367 | -! | -
- ref_cl_name <- as.name(ref_name)- |
-
368 | -! | -
- ref_cl_lbl <- varname_w_label(ref_name, ANL)- |
-
369 | -- |
- }- |
-
370 | -- | - - | -
371 | -! | -
- user_ggplot2_args <- teal.widgets::resolve_ggplot2_args(- |
-
372 | -! | -
- user_plot = ggplot2_args[["Bivariate1"]],- |
-
373 | -! | -
- user_default = ggplot2_args$default- |
-
374 | -- |
- )- |
-
375 | -- | - - | -
376 | -! | -
- ref_call <- bivariate_plot_call(- |
-
377 | -! | -
- data_name = "ANL",- |
-
378 | -! | -
- x = ref_cl_name,- |
-
379 | -! | -
- x_class = ref_class,- |
-
380 | -! | -
- x_label = ref_cl_lbl,- |
-
381 | -! | -
- freq = !show_dist,- |
-
382 | -! | -
- theme = distribution_theme,- |
-
383 | -! | -
- rotate_xaxis_labels = rotate_xaxis_labels,- |
-
384 | -! | -
- swap_axes = FALSE,- |
-
385 | -! | -
- size = size,- |
-
386 | -! | -
- alpha = alpha,- |
-
387 | -! | -
- ggplot2_args = user_ggplot2_args- |
-
388 | -- |
- )- |
-
389 | -- | - - | -
390 | -- |
- # association- |
-
391 | -! | -
- ref_class_cov <- ifelse(association, ref_class, "NULL")- |
-
392 | -- | - - | -
393 | -! | -
- print_call <- quote(print(p))- |
-
394 | -- | - - | -
395 | -! | -
- var_calls <- lapply(vars_names, function(var_i) {- |
-
396 | -! | -
- var_class <- class(ANL[[var_i]])[1]- |
-
397 | -! | -
- if (is.numeric(ANL[[var_i]]) && log_transformation) {- |
-
398 | -- |
- # works for both integers and doubles- |
-
399 | -! | -
- var_cl_name <- call("log", as.name(var_i))- |
-
400 | -! | -
- var_cl_lbl <- varname_w_label(var_i, ANL, prefix = "Log of ")- |
-
401 | -- |
- } else {- |
-
402 | -- |
- # silently ignore when non-numeric even if `log` is selected because some- |
-
403 | -- |
- # variables may be numeric and others not- |
-
404 | -! | -
- var_cl_name <- as.name(var_i)- |
-
405 | -! | -
- var_cl_lbl <- varname_w_label(var_i, ANL)- |
-
406 | -- |
- }- |
-
407 | -- | - - | -
408 | -! | -
- user_ggplot2_args <- teal.widgets::resolve_ggplot2_args(- |
-
409 | -! | -
- user_plot = ggplot2_args[["Bivariate2"]],- |
-
410 | -! | -
- user_default = ggplot2_args$default- |
-
411 | -- |
- )- |
-
412 | -- | - - | -
413 | -! | -
- bivariate_plot_call(- |
-
414 | -! | -
- data_name = "ANL",- |
-
415 | -! | -
- x = ref_cl_name,- |
-
416 | -! | -
- y = var_cl_name,- |
-
417 | -! | -
- x_class = ref_class_cov,- |
-
418 | -! | -
- y_class = var_class,- |
-
419 | -! | -
- x_label = ref_cl_lbl,- |
-
420 | -! | -
- y_label = var_cl_lbl,- |
-
421 | -! | -
- theme = association_theme,- |
-
422 | -! | -
- freq = !show_dist,- |
-
423 | -! | -
- rotate_xaxis_labels = rotate_xaxis_labels,- |
-
424 | -! | -
- swap_axes = swap_axes,- |
-
425 | -! | -
- alpha = alpha,- |
-
426 | -! | -
- size = size,- |
-
427 | -! | -
- ggplot2_args = user_ggplot2_args- |
-
428 | -- |
- )- |
-
429 | -- |
- })- |
-
430 | -- | - - | -
431 | -- |
- # helper function to format variable name- |
-
432 | -! | -
- format_varnames <- function(x) {- |
-
433 | -! | -
- if (is.numeric(ANL[[x]]) && log_transformation) {- |
-
434 | -! | -
- varname_w_label(x, ANL, prefix = "Log of ")- |
-
435 | -- |
- } else {- |
-
436 | -! | -
- varname_w_label(x, ANL)- |
-
437 | -- |
- }- |
-
438 | -- |
- }- |
-
439 | -! | -
- new_title <-- |
-
440 | -! | -
- if (association) {- |
-
441 | -! | -
- switch(as.character(length(vars_names)),- |
-
442 | -! | -
- "0" = sprintf("Value distribution for %s", ref_cl_lbl),- |
-
443 | -! | -
- "1" = sprintf(- |
-
444 | -! | -
- "Association between %s and %s",- |
-
445 | -! | -
- ref_cl_lbl,- |
-
446 | -! | -
- format_varnames(vars_names)- |
-
447 | -- |
- ),- |
-
448 | -! | -
- sprintf(- |
-
449 | -! | -
- "Associations between %s and: %s",- |
-
450 | -! | -
- ref_cl_lbl,- |
-
451 | -! | -
- paste(lapply(vars_names, format_varnames), collapse = ", ")- |
-
452 | -- |
- )- |
-
453 | -- |
- )- |
-
454 | -- |
- } else {- |
-
455 | -! | -
- switch(as.character(length(vars_names)),- |
-
456 | -! | -
- "0" = sprintf("Value distribution for %s", ref_cl_lbl),- |
-
457 | -! | -
- sprintf(- |
-
458 | -! | -
- "Value distributions for %s and %s",- |
-
459 | -! | -
- ref_cl_lbl,- |
-
460 | -! | -
- paste(lapply(vars_names, format_varnames), collapse = ", ")- |
-
461 | -- |
- )- |
-
462 | -- |
- )- |
-
463 | -- |
- }- |
-
464 | -- | - - | -
465 | -! | -
- teal.code::eval_code(- |
-
466 | -! | -
- merged$anl_q_r(),- |
-
467 | -! | -
- substitute(- |
-
468 | -! | -
- expr = title <- new_title,- |
-
469 | -! | -
- env = list(new_title = new_title)- |
-
470 | -- |
- )- |
-
471 | -- |
- ) %>%- |
-
472 | -! | -
- teal.code::eval_code(- |
-
473 | -! | -
- substitute(- |
-
474 | -! | -
- expr = {- |
-
475 | -! | -
- plots <- plot_calls- |
-
476 | -! | -
- p <- tern::stack_grobs(grobs = lapply(plots, ggplotGrob))- |
-
477 | -! | -
- grid::grid.newpage()- |
-
478 | -! | -
- grid::grid.draw(p)- |
-
479 | -- |
- },- |
-
480 | -! | -
- env = list(- |
-
481 | -! | -
- plot_calls = do.call(- |
-
482 | -! | -
- "call",- |
-
483 | -! | -
- c(list("list", ref_call), var_calls),- |
-
484 | -! | -
- quote = TRUE- |
-
485 | -- |
- )- |
-
486 | -- |
- )- |
-
487 | -- |
- )- |
-
488 | -- |
- )- |
-
489 | -- |
- })- |
-
490 | -- | - - | -
491 | -! | -
- plot_r <- shiny::reactive({- |
-
492 | -! | -
- shiny::req(iv_r()$is_valid())- |
-
493 | -! | -
- output_q()[["p"]]- |
-
494 | -- |
- })- |
-
495 | -- | - - | -
496 | -! | -
- pws <- teal.widgets::plot_with_settings_srv(- |
-
497 | -! | -
- id = "myplot",- |
-
498 | -! | -
- plot_r = plot_r,- |
-
499 | -! | -
- height = plot_height,- |
-
500 | -! | -
- width = plot_width- |
-
501 | -- |
- )- |
-
502 | -- | - - | -
503 | -! | -
- output$title <- renderText({- |
-
504 | -! | -
- teal.code::dev_suppress(output_q()[["title"]])- |
-
505 | -- |
- })- |
-
506 | -- | - - | -
507 | -! | -
- teal.widgets::verbatim_popup_srv(- |
-
508 | -! | -
- id = "warning",- |
-
509 | -! | -
- verbatim_content = reactive(teal.code::get_warnings(output_q())),- |
-
510 | -! | -
- title = "Warning",- |
-
511 | -! | -
- disabled = reactive(is.null(teal.code::get_warnings(output_q())))- |
-
512 | -- |
- )- |
-
513 | -- | - - | -
514 | -! | -
- teal.widgets::verbatim_popup_srv(- |
-
515 | -! | -
- id = "rcode",- |
-
516 | -! | -
- verbatim_content = reactive(teal.code::get_code(output_q())),- |
-
517 | -! | -
- title = "Association Plot"- |
-
518 | -- |
- )- |
-
519 | -- | - - | -
520 | -- |
- ### REPORTER- |
-
521 | -! | -
- if (with_reporter) {- |
-
522 | -! | -
- card_fun <- function(comment, label) {- |
-
523 | -! | -
- card <- teal::report_card_template(- |
-
524 | -! | -
- title = "Association Plot",- |
-
525 | -! | -
- label = label,- |
-
526 | -! | -
- with_filter = with_filter,- |
-
527 | -! | -
- filter_panel_api = filter_panel_api- |
-
528 | -- |
- )- |
-
529 | -! | -
- card$append_text("Plot", "header3")- |
-
530 | -! | -
- card$append_plot(plot_r(), dim = pws$dim())- |
-
531 | -! | -
- if (!comment == "") {- |
-
532 | -! | -
- card$append_text("Comment", "header3")- |
-
533 | -! | -
- card$append_text(comment)- |
-
534 | -- |
- }- |
-
535 | -! | -
- card$append_src(teal.code::get_code(output_q()))- |
-
536 | -! | -
- card- |
-
537 | -- |
- }- |
-
538 | -! | -
- teal.reporter::simple_reporter_srv("simple_reporter", reporter = reporter, card_fun = card_fun)- |
-
539 | -- |
- }- |
-
540 | -- |
- ###- |
-
541 | -- |
- })- |
-
542 | -- |
- }- |
-
1 | -- |
- #' `teal` module: Variable browser- |
-
2 | -- |
- #'- |
-
3 | -- |
- #' Module provides provides a detailed summary and visualization of variable distributions- |
-
4 | -- |
- #' for `data.frame` objects, with interactive features to customize analysis.- |
-
5 | -- |
- #'- |
-
6 | -- |
- #' Numeric columns with fewer than 30 distinct values can be treated as either discrete- |
-
7 | -- |
- #' or continuous with a checkbox allowing users to switch how they are treated(if < 6 unique values- |
-
8 | -- |
- #' then the default is discrete, otherwise it is continuous).- |
-
9 | -- |
- #'- |
-
10 | -- |
- #' @inheritParams teal::module- |
-
11 | -- |
- #' @inheritParams shared_params- |
-
12 | -- |
- #' @param parent_dataname (`character(1)`) string specifying a parent dataset.- |
-
13 | -- |
- #' If it exists in `datasets_selected`then an extra checkbox will be shown to- |
-
14 | -- |
- #' allow users to not show variables in other datasets which exist in this `dataname`.- |
-
15 | -- |
- #' This is typically used to remove `ADSL` columns in `CDISC` data.- |
-
16 | -- |
- #' In non `CDISC` data this can be ignored. Defaults to `"ADSL"`.- |
-
17 | -- |
- #' @param datasets_selected (`character`) vector of datasets which should be- |
-
18 | -- |
- #' shown, in order. Names must correspond with datasets names.- |
-
19 | -- |
- #' If vector of length zero (default) then all datasets are shown.- |
-
20 | -- |
- #' Note: Only `data.frame` objects are compatible; using other types will cause an error.- |
-
21 | -- |
- #'- |
-
22 | -- |
- #' @inherit shared_params return- |
-
23 | -- |
- #'- |
-
24 | -- |
- #' @examples- |
-
25 | -- |
- #' library(teal.widgets)- |
-
26 | -- |
- #'- |
-
27 | -- |
- #' # Module specification used in apps below- |
-
28 | -- |
- #' tm_variable_browser_module <- tm_variable_browser(- |
-
29 | -- |
- #' label = "Variable browser",- |
-
30 | -- |
- #' ggplot2_args = ggplot2_args(- |
-
31 | -- |
- #' labs = list(subtitle = "Plot generated by Variable Browser Module")- |
-
32 | -- |
- #' )- |
-
33 | -- |
- #' )- |
-
34 | -- |
- #'- |
-
35 | -- |
- #' # general data example- |
-
36 | -- |
- #' data <- teal_data()- |
-
37 | -- |
- #' data <- within(data, {- |
-
38 | -- |
- #' iris <- iris- |
-
39 | -- |
- #' mtcars <- mtcars- |
-
40 | -- |
- #' women <- women- |
-
41 | -- |
- #' faithful <- faithful- |
-
42 | -- |
- #' CO2 <- CO2- |
-
43 | -- |
- #' })- |
-
44 | -- |
- #' datanames(data) <- c("iris", "mtcars", "women", "faithful", "CO2")- |
-
45 | -- |
- #'- |
-
46 | -- |
- #' app <- init(- |
-
47 | -- |
- #' data = data,- |
-
48 | -- |
- #' modules = modules(tm_variable_browser_module)- |
-
49 | -- |
- #' )- |
-
50 | -- |
- #' if (interactive()) {- |
-
51 | -- |
- #' shinyApp(app$ui, app$server)- |
-
52 | -- |
- #' }- |
-
53 | -- |
- #'- |
-
54 | -- |
- #' # CDISC example data- |
-
55 | -- |
- #' data <- teal_data()- |
-
56 | -- |
- #' data <- within(data, {- |
-
57 | -- |
- #' ADSL <- rADSL- |
-
58 | -- |
- #' ADTTE <- rADTTE- |
-
59 | -- |
- #' })- |
-
60 | -- |
- #' datanames(data) <- c("ADSL", "ADTTE")- |
-
61 | -- |
- #' join_keys(data) <- default_cdisc_join_keys[datanames(data)]- |
-
62 | -- |
- #'- |
-
63 | -- |
- #' app <- init(- |
-
64 | -- |
- #' data = data,- |
-
65 | -- |
- #' modules = modules(tm_variable_browser_module)- |
-
66 | -- |
- #' )- |
-
67 | -- |
- #' if (interactive()) {- |
-
68 | -- |
- #' shinyApp(app$ui, app$server)- |
-
69 | -- |
- #' }- |
-
70 | -- |
- #'- |
-
71 | -- |
- #' @export- |
-
72 | -- |
- #'- |
-
73 | -- |
- tm_variable_browser <- function(label = "Variable Browser",- |
-
74 | -- |
- datasets_selected = character(0),- |
-
75 | -- |
- parent_dataname = "ADSL",- |
-
76 | -- |
- pre_output = NULL,- |
-
77 | -- |
- post_output = NULL,- |
-
78 | -- |
- ggplot2_args = teal.widgets::ggplot2_args()) {- |
-
79 | -! | -
- logger::log_info("Initializing tm_variable_browser")- |
-
80 | -- | - - | -
81 | -- |
- # Requires Suggested packages- |
-
82 | -! | -
- if (!requireNamespace("sparkline", quietly = TRUE)) {- |
-
83 | -! | -
- stop("Cannot load sparkline - please install the package or restart your session.")- |
-
84 | -- |
- }- |
-
85 | -! | -
- if (!requireNamespace("htmlwidgets", quietly = TRUE)) {- |
-
86 | -! | -
- stop("Cannot load htmlwidgets - please install the package or restart your session.")- |
-
87 | -- |
- }- |
-
88 | -! | -
- if (!requireNamespace("jsonlite", quietly = TRUE)) {- |
-
89 | -! | -
- stop("Cannot load jsonlite - please install the package or restart your session.")- |
-
90 | -- |
- }- |
-
91 | -- | - - | -
92 | -- |
- # Start of assertions- |
-
93 | -! | -
- checkmate::assert_string(label)- |
-
94 | -! | -
- checkmate::assert_character(datasets_selected)- |
-
95 | -! | -
- checkmate::assert_character(parent_dataname, min.len = 0, max.len = 1)- |
-
96 | -! | -
- checkmate::assert_multi_class(pre_output, c("shiny.tag", "shiny.tag.list", "html"), null.ok = TRUE)- |
-
97 | -! | -
- checkmate::assert_multi_class(post_output, c("shiny.tag", "shiny.tag.list", "html"), null.ok = TRUE)- |
-
98 | -! | -
- checkmate::assert_class(ggplot2_args, "ggplot2_args")- |
-
99 | -- |
- # End of assertions- |
-
100 | -- | - - | -
101 | -! | -
- datasets_selected <- unique(datasets_selected)- |
-
102 | -- | - - | -
103 | -! | -
- module(- |
-
104 | -! | -
- label,- |
-
105 | -! | -
- server = srv_variable_browser,- |
-
106 | -! | -
- ui = ui_variable_browser,- |
-
107 | -! | -
- datanames = "all",- |
-
108 | -! | -
- server_args = list(- |
-
109 | -! | -
- datasets_selected = datasets_selected,- |
-
110 | -! | -
- parent_dataname = parent_dataname,- |
-
111 | -! | -
- ggplot2_args = ggplot2_args- |
-
112 | -- |
- ),- |
-
113 | -! | -
- ui_args = list(- |
-
114 | -! | -
- pre_output = pre_output,- |
-
115 | -! | -
- post_output = post_output- |
-
116 | -- |
- )- |
-
117 | -- |
- )- |
-
118 | -- |
- }- |
-
119 | -- | - - | -
120 | -- |
- # UI function for the variable browser module- |
-
121 | -- |
- ui_variable_browser <- function(id,- |
-
122 | -- |
- pre_output = NULL,- |
-
123 | -- |
- post_output = NULL) {- |
-
124 | -! | -
- ns <- NS(id)- |
-
125 | -- | - - | -
126 | -! | -
- shiny::tagList(- |
-
127 | -! | -
- include_css_files("custom"),- |
-
128 | -! | -
- shinyjs::useShinyjs(),- |
-
129 | -! | -
- teal.widgets::standard_layout(- |
-
130 | -! | -
- output = fluidRow(- |
-
131 | -! | -
- htmlwidgets::getDependency("sparkline"), # needed for sparklines to work- |
-
132 | -! | -
- column(- |
-
133 | -! | -
- 6,- |
-
134 | -- |
- # variable browser- |
-
135 | -! | -
- teal.widgets::white_small_well(- |
-
136 | -! | -
- uiOutput(ns("ui_variable_browser")),- |
-
137 | -! | -
- shinyjs::hidden({- |
-
138 | -! | -
- checkboxInput(ns("show_parent_vars"), "Show parent dataset variables", value = FALSE)- |
-
139 | -- |
- })- |
-
140 | -- |
- )- |
-
141 | -- |
- ),- |
-
142 | -! | -
- column(- |
-
143 | -! | -
- 6,- |
-
144 | -! | -
- teal.widgets::white_small_well(- |
-
145 | -- |
- ### Reporter- |
-
146 | -! | -
- teal.reporter::simple_reporter_ui(ns("simple_reporter")),- |
-
147 | -- |
- ###- |
-
148 | -! | -
- div(- |
-
149 | -! | -
- class = "block",- |
-
150 | -! | -
- uiOutput(ns("ui_histogram_display"))- |
-
151 | -- |
- ),- |
-
152 | -! | -
- div(- |
-
153 | -! | -
- class = "block",- |
-
154 | -! | -
- uiOutput(ns("ui_numeric_display"))- |
-
155 | -- |
- ),- |
-
156 | -! | -
- teal.widgets::plot_with_settings_ui(ns("variable_plot")),- |
-
157 | -! | -
- br(),- |
-
158 | -- |
- # input user-defined text size- |
-
159 | -! | -
- teal.widgets::panel_item(- |
-
160 | -! | -
- title = "Plot settings",- |
-
161 | -! | -
- collapsed = TRUE,- |
-
162 | -! | -
- selectInput(- |
-
163 | -! | -
- inputId = ns("ggplot_theme"), label = "ggplot2 theme",- |
-
164 | -! | -
- choices = ggplot_themes,- |
-
165 | -! | -
- selected = "grey"- |
-
166 | -- |
- ),- |
-
167 | -! | -
- fluidRow(- |
-
168 | -! | -
- column(6, sliderInput(- |
-
169 | -! | -
- inputId = ns("font_size"), label = "font size",- |
-
170 | -! | -
- min = 5L, max = 30L, value = 15L, step = 1L, ticks = FALSE- |
-
171 | -- |
- )),- |
-
172 | -! | -
- column(6, sliderInput(- |
-
173 | -! | -
- inputId = ns("label_rotation"), label = "rotate x labels",- |
-
174 | -! | -
- min = 0L, max = 90L, value = 45L, step = 1, ticks = FALSE- |
-
175 | -- |
- ))- |
-
176 | -- |
- )- |
-
177 | -- |
- ),- |
-
178 | -! | -
- br(),- |
-
179 | -! | -
- teal.widgets::get_dt_rows(ns("variable_summary_table"), ns("variable_summary_table_rows")),- |
-
180 | -! | -
- DT::dataTableOutput(ns("variable_summary_table"))- |
-
181 | -- |
- )- |
-
182 | -- |
- )- |
-
183 | -- |
- ),- |
-
184 | -! | -
- pre_output = pre_output,- |
-
185 | -! | -
- post_output = post_output- |
-
186 | -- |
- )- |
-
187 | -- |
- )- |
-
188 | -- |
- }- |
-
189 | -- | - - | -
190 | -- |
- # Server function for the variable browser module- |
-
191 | -- |
- srv_variable_browser <- function(id,- |
-
192 | -- |
- data,- |
-
193 | -- |
- reporter,- |
-
194 | -- |
- filter_panel_api,- |
-
195 | -- |
- datasets_selected, parent_dataname, ggplot2_args) {- |
-
196 | -! | -
- with_reporter <- !missing(reporter) && inherits(reporter, "Reporter")- |
-
197 | -! | -
- with_filter <- !missing(filter_panel_api) && inherits(filter_panel_api, "FilterPanelAPI")- |
-
198 | -! | -
- checkmate::assert_class(data, "reactive")- |
-
199 | -! | -
- checkmate::assert_class(isolate(data()), "teal_data")- |
-
200 | -! | -
- moduleServer(id, function(input, output, session) {- |
-
201 | -- |
- # if there are < this number of unique records then a numeric- |
-
202 | -- |
- # variable can be treated as a factor and all factors with < this groups- |
-
203 | -- |
- # have their values plotted- |
-
204 | -! | -
- .unique_records_for_factor <- 30- |
-
205 | -- |
- # if there are < this number of unique records then a numeric- |
-
206 | -- |
- # variable is by default treated as a factor- |
-
207 | -! | -
- .unique_records_default_as_factor <- 6 # nolint: object_length.- |
-
208 | -- | - - | -
209 | -! | -
- varname_numeric_as_factor <- reactiveValues()- |
-
210 | -- | - - | -
211 | -! | -
- datanames <- isolate(teal.data::datanames(data()))- |
-
212 | -! | -
- datanames <- Filter(function(name) {- |
-
213 | -! | -
- is.data.frame(isolate(data())[[name]])- |
-
214 | -! | -
- }, datanames)- |
-
215 | -- | - - | -
216 | -! | -
- checkmate::assert_character(datasets_selected)- |
-
217 | -! | -
- checkmate::assert_subset(datasets_selected, datanames)- |
-
218 | -! | -
- if (!identical(datasets_selected, character(0))) {- |
-
219 | -! | -
- checkmate::assert_subset(datasets_selected, datanames)- |
-
220 | -! | -
- datanames <- datasets_selected- |
-
221 | -- |
- }- |
-
222 | -- | - - | -
223 | -! | -
- output$ui_variable_browser <- renderUI({- |
-
224 | -! | -
- ns <- session$ns- |
-
225 | -! | -
- do.call(- |
-
226 | -! | -
- tabsetPanel,- |
-
227 | -! | -
- c(- |
-
228 | -! | -
- id = ns("tabset_panel"),- |
-
229 | -! | -
- do.call(- |
-
230 | -! | -
- tagList,- |
-
231 | -! | -
- lapply(datanames, function(dataname) {- |
-
232 | -! | -
- tabPanel(- |
-
233 | -! | -
- dataname,- |
-
234 | -! | -
- div(- |
-
235 | -! | -
- class = "mt-4",- |
-
236 | -! | -
- textOutput(ns(paste0("dataset_summary_", dataname)))- |
-
237 | -- |
- ),- |
-
238 | -! | -
- div(- |
-
239 | -! | -
- class = "mt-4",- |
-
240 | -! | -
- teal.widgets::get_dt_rows(- |
-
241 | -! | -
- ns(paste0("variable_browser_", dataname)),- |
-
242 | -! | -
- ns(paste0("variable_browser_", dataname, "_rows"))- |
-
243 | -- |
- ),- |
-
244 | -! | -
- DT::dataTableOutput(ns(paste0("variable_browser_", dataname)), width = "100%")- |
-
245 | -- |
- )- |
-
246 | -- |
- )- |
-
247 | -- |
- })- |
-
248 | -- |
- )- |
-
249 | -- |
- )- |
-
250 | -- |
- )- |
-
251 | -- |
- })- |
-
252 | -- | - - | -
253 | -- |
- # conditionally display checkbox- |
-
254 | -! | -
- shinyjs::toggle(- |
-
255 | -! | -
- id = "show_parent_vars",- |
-
256 | -! | -
- condition = length(parent_dataname) > 0 && parent_dataname %in% datanames- |
-
257 | -- |
- )- |
-
258 | -- | - - | -
259 | -! | -
- columns_names <- new.env()- |
-
260 | -- | - - | -
261 | -- |
- # plot_var$data holds the name of the currently selected dataset- |
-
262 | -- |
- # plot_var$variable[[<dataset_name>]] holds the name of the currently selected- |
-
263 | -- |
- # variable for dataset <dataset_name>- |
-
264 | -! | -
- plot_var <- reactiveValues(data = NULL, variable = list())- |
-
265 | -- | - - | -
266 | -! | -
- establish_updating_selection(datanames, input, plot_var, columns_names)- |
-
267 | -- | - - | -
268 | -- |
- # validations- |
-
269 | -! | -
- validation_checks <- validate_input(input, plot_var, data)- |
-
270 | -- | - - | -
271 | -- |
- # data_for_analysis is a list with two elements: a column from a dataset and the column label- |
-
272 | -! | -
- plotted_data <- reactive({- |
-
273 | -! | -
- validation_checks()- |
-
274 | -- | - - | -
275 | -! | -
- get_plotted_data(input, plot_var, data)- |
-
276 | -- |
- })- |
-
277 | -- | - - | -
278 | -! | -
- treat_numeric_as_factor <- reactive({- |
-
279 | -! | -
- if (is_num_var_short(.unique_records_for_factor, input, plotted_data)) {- |
-
280 | -! | -
- input$numeric_as_factor- |
-
281 | -- |
- } else {- |
-
282 | -! | -
- FALSE- |
-
283 | -- |
- }- |
-
284 | -- |
- })- |
-
285 | -- | - - | -
286 | -! | -
- render_tabset_panel_content(- |
-
287 | -! | -
- input = input,- |
-
288 | -! | -
- output = output,- |
-
289 | -! | -
- data = data,- |
-
290 | -! | -
- datanames = datanames,- |
-
291 | -! | -
- parent_dataname = parent_dataname,- |
-
292 | -! | -
- columns_names = columns_names,- |
-
293 | -! | -
- plot_var = plot_var- |
-
294 | -- |
- )- |
-
295 | -- |
- # add used-defined text size to ggplot arguments passed from caller frame- |
-
296 | -! | -
- all_ggplot2_args <- reactive({- |
-
297 | -! | -
- user_text <- teal.widgets::ggplot2_args(- |
-
298 | -! | -
- theme = list(- |
-
299 | -! | -
- "text" = ggplot2::element_text(size = input[["font_size"]]),- |
-
300 | -! | -
- "axis.text.x" = ggplot2::element_text(angle = input[["label_rotation"]], hjust = 1)- |
-
301 | -- |
- )- |
-
302 | -- |
- )- |
-
303 | -! | -
- user_theme <- utils::getFromNamespace(sprintf("theme_%s", input[["ggplot_theme"]]), ns = "ggplot2")- |
-
304 | -! | -
- user_theme <- user_theme()- |
-
305 | -- |
- # temporary fix to circumvent assertion issue with resolve_ggplot2_args- |
-
306 | -- |
- # drop problematic elements- |
-
307 | -! | -
- user_theme <- user_theme[grep("strip.text.y.left", names(user_theme), fixed = TRUE, invert = TRUE)]- |
-
308 | -- | - - | -
309 | -! | -
- teal.widgets::resolve_ggplot2_args(- |
-
310 | -! | -
- user_plot = user_text,- |
-
311 | -! | -
- user_default = teal.widgets::ggplot2_args(theme = user_theme),- |
-
312 | -! | -
- module_plot = ggplot2_args- |
-
313 | -- |
- )- |
-
314 | -- |
- })- |
-
315 | -- | - - | -
316 | -! | -
- output$ui_numeric_display <- renderUI({- |
-
317 | -! | -
- validation_checks()- |
-
318 | -! | -
- dataname <- input$tabset_panel- |
-
319 | -! | -
- varname <- plot_var$variable[[dataname]]- |
-
320 | -! | -
- df <- data()[[dataname]]- |
-
321 | -- | - - | -
322 | -! | -
- numeric_ui <- tagList(- |
-
323 | -! | -
- fluidRow(- |
-
324 | -! | -
- div(- |
-
325 | -! | -
- class = "col-md-4",- |
-
326 | -! | -
- br(),- |
-
327 | -! | -
- shinyWidgets::switchInput(- |
-
328 | -! | -
- inputId = session$ns("display_density"),- |
-
329 | -! | -
- label = "Show density",- |
-
330 | -! | -
- value = `if`(is.null(isolate(input$display_density)), TRUE, isolate(input$display_density)),- |
-
331 | -! | -
- width = "50%",- |
-
332 | -! | -
- labelWidth = "100px",- |
-
333 | -! | -
- handleWidth = "50px"- |
-
334 | -- |
- )- |
-
335 | -- |
- ),- |
-
336 | -! | -
- div(- |
-
337 | -! | -
- class = "col-md-4",- |
-
338 | -! | -
- br(),- |
-
339 | -! | -
- shinyWidgets::switchInput(- |
-
340 | -! | -
- inputId = session$ns("remove_outliers"),- |
-
341 | -! | -
- label = "Remove outliers",- |
-
342 | -! | -
- value = `if`(is.null(isolate(input$remove_outliers)), FALSE, isolate(input$remove_outliers)),- |
-
343 | -! | -
- width = "50%",- |
-
344 | -! | -
- labelWidth = "100px",- |
-
345 | -! | -
- handleWidth = "50px"- |
-
346 | -- |
- )- |
-
347 | -- |
- ),- |
-
348 | -! | -
- div(- |
-
349 | -! | -
- class = "col-md-4",- |
-
350 | -! | -
- uiOutput(session$ns("outlier_definition_slider_ui"))- |
-
351 | -- |
- )- |
-
352 | -- |
- ),- |
-
353 | -! | -
- div(- |
-
354 | -! | -
- class = "ml-4",- |
-
355 | -! | -
- uiOutput(session$ns("ui_density_help")),- |
-
356 | -! | -
- uiOutput(session$ns("ui_outlier_help"))- |
-
357 | -- |
- )- |
-
358 | -- |
- )- |
-
359 | -- | - - | -
360 | -! | -
- observeEvent(input$numeric_as_factor, ignoreInit = TRUE, {- |
-
361 | -! | -
- varname_numeric_as_factor[[plot_var$variable[[dataname]]]] <- input$numeric_as_factor- |
-
362 | -- |
- })- |
-
363 | -- | - - | -
364 | -! | -
- if (is.numeric(df[[varname]])) {- |
-
365 | -! | -
- unique_entries <- length(unique(df[[varname]]))- |
-
366 | -! | -
- if (unique_entries < .unique_records_for_factor && unique_entries > 0) {- |
-
367 | -! | -
- list(- |
-
368 | -! | -
- checkboxInput(- |
-
369 | -! | -
- session$ns("numeric_as_factor"),- |
-
370 | -! | -
- "Treat variable as factor",- |
-
371 | -! | -
- value = `if`(- |
-
372 | -! | -
- is.null(varname_numeric_as_factor[[varname]]),- |
-
373 | -! | -
- unique_entries < .unique_records_default_as_factor,- |
-
374 | -! | -
- varname_numeric_as_factor[[varname]]- |
-
375 | -- |
- )- |
-
376 | -- |
- ),- |
-
377 | -! | -
- conditionalPanel("!input.numeric_as_factor", ns = session$ns, numeric_ui)- |
-
378 | -- |
- )- |
-
379 | -! | -
- } else if (unique_entries > 0) {- |
-
380 | -! | -
- numeric_ui- |
-
381 | -- |
- }- |
-
382 | -- |
- } else {- |
-
383 | -! | -
- NULL- |
-
384 | -- |
- }- |
-
385 | -- |
- })- |
-
386 | -- | - - | -
387 | -! | -
- output$ui_histogram_display <- renderUI({- |
-
388 | -! | -
- validation_checks()- |
-
389 | -! | -
- dataname <- input$tabset_panel- |
-
390 | -! | -
- varname <- plot_var$variable[[dataname]]- |
-
391 | -! | -
- df <- data()[[dataname]]- |
-
392 | -- | - - | -
393 | -! | -
- numeric_ui <- tagList(fluidRow(- |
-
394 | -! | -
- div(- |
-
395 | -! | -
- class = "col-md-4",- |
-
396 | -! | -
- shinyWidgets::switchInput(- |
-
397 | -! | -
- inputId = session$ns("remove_NA_hist"),- |
-
398 | -! | -
- label = "Remove NA values",- |
-
399 | -! | -
- value = FALSE,- |
-
400 | -! | -
- width = "50%",- |
-
401 | -! | -
- labelWidth = "100px",- |
-
402 | -! | -
- handleWidth = "50px"- |
-
403 | -- |
- )- |
-
404 | -- |
- )- |
-
405 | -- |
- ))- |
-
406 | -- | - - | -
407 | -! | -
- var <- df[[varname]]- |
-
408 | -! | -
- if (anyNA(var) && (is.factor(var) || is.character(var) || is.logical(var))) {- |
-
409 | -! | -
- groups <- unique(as.character(var))- |
-
410 | -! | -
- len_groups <- length(groups)- |
-
411 | -! | -
- if (len_groups >= .unique_records_for_factor) {- |
-
412 | -! | -
- NULL- |
-
413 | -- |
- } else {- |
-
414 | -! | -
- numeric_ui- |
-
415 | -- |
- }- |
-
416 | -- |
- } else {- |
-
417 | -! | -
- NULL- |
-
418 | -- |
- }- |
-
419 | -- |
- })- |
-
420 | -- | - - | -
421 | -! | -
- output$outlier_definition_slider_ui <- renderUI({- |
-
422 | -! | -
- req(input$remove_outliers)- |
-
423 | -! | -
- sliderInput(- |
-
424 | -! | -
- inputId = session$ns("outlier_definition_slider"),- |
-
425 | -! | -
- div(- |
-
426 | -! | -
- class = "teal-tooltip",- |
-
427 | -! | -
- tagList(- |
-
428 | -! | -
- "Outlier definition:",- |
-
429 | -! | -
- icon("circle-info"),- |
-
430 | -! | -
- span(- |
-
431 | -! | -
- class = "tooltiptext",- |
-
432 | -! | -
- paste(- |
-
433 | -! | -
- "Use the slider to choose the cut-off value to define outliers; the larger the value the",- |
-
434 | -! | -
- "further below Q1/above Q3 points have to be in order to be classed as outliers"- |
-
435 | -- |
- )- |
-
436 | -- |
- )- |
-
437 | -- |
- )- |
-
438 | -- |
- ),- |
-
439 | -! | -
- min = 1,- |
-
440 | -! | -
- max = 5,- |
-
441 | -! | -
- value = 3,- |
-
442 | -! | -
- step = 0.5- |
-
443 | -- |
- )- |
-
444 | -- |
- })- |
-
445 | -- | - - | -
446 | -! | -
- output$ui_density_help <- renderUI({- |
-
447 | -! | -
- req(is.logical(input$display_density))- |
-
448 | -! | -
- if (input$display_density) {- |
-
449 | -! | -
- tags$small(helpText(paste(- |
-
450 | -! | -
- "Kernel density estimation with gaussian kernel",- |
-
451 | -! | -
- "and bandwidth function bw.nrd0 (R default)"- |
-
452 | -- |
- )))- |
-
453 | -- |
- } else {- |
-
454 | -! | -
- NULL- |
-
455 | -- |
- }- |
-
456 | -- |
- })- |
-
457 | -- | - - | -
458 | -! | -
- output$ui_outlier_help <- renderUI({- |
-
459 | -! | -
- req(is.logical(input$remove_outliers), input$outlier_definition_slider)- |
-
460 | -! | -
- if (input$remove_outliers) {- |
-
461 | -! | -
- tags$small(- |
-
462 | -! | -
- helpText(- |
-
463 | -! | -
- withMathJax(paste0(- |
-
464 | -! | -
- "Outlier data points (\\( X \\lt Q1 - ", input$outlier_definition_slider, "\\times IQR \\) or- |
-
465 | -! | -
- \\(Q3 + ", input$outlier_definition_slider, "\\times IQR \\lt X\\))- |
-
466 | -! | -
- have not been displayed on the graph and will not be used for any kernel density estimations, ",- |
-
467 | -! | -
- "although their values remain in the statisics table below."- |
-
468 | -- |
- ))- |
-
469 | -- |
- )- |
-
470 | -- |
- )- |
-
471 | -- |
- } else {- |
-
472 | -! | -
- NULL- |
-
473 | -- |
- }- |
-
474 | -- |
- })- |
-
475 | -- | - - | -
476 | -- | - - | -
477 | -! | -
- variable_plot_r <- reactive({- |
-
478 | -! | -
- display_density <- `if`(is.null(input$display_density), FALSE, input$display_density)- |
-
479 | -! | -
- remove_outliers <- `if`(is.null(input$remove_outliers), FALSE, input$remove_outliers)- |
-
480 | -- | - - | -
481 | -! | -
- if (remove_outliers) {- |
-
482 | -! | -
- req(input$outlier_definition_slider)- |
-
483 | -! | -
- outlier_definition <- as.numeric(input$outlier_definition_slider)- |
-
484 | -- |
- } else {- |
-
485 | -! | -
- outlier_definition <- 0- |
-
486 | -- |
- }- |
-
487 | -- | - - | -
488 | -! | -
- plot_var_summary(- |
-
489 | -! | -
- var = plotted_data()$data,- |
-
490 | -! | -
- var_lab = plotted_data()$var_description,- |
-
491 | -! | -
- wrap_character = 15,- |
-
492 | -! | -
- numeric_as_factor = treat_numeric_as_factor(),- |
-
493 | -! | -
- remove_NA_hist = input$remove_NA_hist,- |
-
494 | -! | -
- display_density = display_density,- |
-
495 | -! | -
- outlier_definition = outlier_definition,- |
-
496 | -! | -
- records_for_factor = .unique_records_for_factor,- |
-
497 | -! | -
- ggplot2_args = all_ggplot2_args()- |
-
498 | -- |
- )- |
-
499 | -- |
- })- |
-
500 | -- | - - | -
501 | -! | -
- pws <- teal.widgets::plot_with_settings_srv(- |
-
502 | -! | -
- id = "variable_plot",- |
-
503 | -! | -
- plot_r = variable_plot_r,- |
-
504 | -! | -
- height = c(500, 200, 2000)- |
-
505 | -- |
- )- |
-
506 | -- | - - | -
507 | -! | -
- output$variable_summary_table <- DT::renderDataTable({- |
-
508 | -! | -
- var_summary_table(- |
-
509 | -! | -
- plotted_data()$data,- |
-
510 | -! | -
- treat_numeric_as_factor(),- |
-
511 | -! | -
- input$variable_summary_table_rows,- |
-
512 | -! | -
- if (!is.null(input$remove_outliers) && input$remove_outliers) {- |
-
513 | -! | -
- req(input$outlier_definition_slider)- |
-
514 | -! | -
- as.numeric(input$outlier_definition_slider)- |
-
515 | -- |
- } else {- |
-
516 | -! | -
- 0- |
-
517 | -- |
- }- |
-
518 | -- |
- )- |
-
519 | -- |
- })- |
-
520 | -- | - - | -
521 | -- |
- ### REPORTER- |
-
522 | -! | -
- if (with_reporter) {- |
-
523 | -! | -
- card_fun <- function(comment) {- |
-
524 | -! | -
- card <- teal::TealReportCard$new()- |
-
525 | -! | -
- card$set_name("Variable Browser Plot")- |
-
526 | -! | -
- card$append_text("Variable Browser Plot", "header2")- |
-
527 | -! | -
- if (with_filter) card$append_fs(filter_panel_api$get_filter_state())- |
-
528 | -! | -
- card$append_text("Plot", "header3")- |
-
529 | -! | -
- card$append_plot(variable_plot_r(), dim = pws$dim())- |
-
530 | -! | -
- if (!comment == "") {- |
-
531 | -! | -
- card$append_text("Comment", "header3")- |
-
532 | -! | -
- card$append_text(comment)- |
-
533 | -- |
- }- |
-
534 | -! | -
- card- |
-
535 | -- |
- }- |
-
536 | -! | -
- teal.reporter::simple_reporter_srv("simple_reporter", reporter = reporter, card_fun = card_fun)- |
-
537 | -- |
- }- |
-
538 | -- |
- ###- |
-
539 | -- |
- })- |
-
540 | -- |
- }- |
-
541 | -- | - - | -
542 | -- |
- #' Summarize NAs.- |
-
543 | -- |
- #'- |
-
544 | -- |
- #' Summarizes occurrence of missing values in vector.- |
-
545 | -- |
- #' @param x vector of any type and length- |
-
546 | -- |
- #' @return Character string describing `NA` occurrence.- |
-
547 | -- |
- #' @keywords internal- |
-
548 | -- |
- var_missings_info <- function(x) {- |
-
549 | -! | -
- sprintf("%s [%s%%]", sum(is.na(x)), round(mean(is.na(x) * 100), 2))- |
-
550 | -- |
- }- |
-
551 | -- | - - | -
552 | -- |
- #' Summarizes variable- |
-
553 | -- |
- #'- |
-
554 | -- |
- #' Creates html summary with statistics relevant to data type. For numeric values it returns central- |
-
555 | -- |
- #' tendency measures, for factor returns level counts, for Date date range, for other just- |
-
556 | -- |
- #' number of levels.- |
-
557 | -- |
- #'- |
-
558 | -- |
- #' @param x vector of any type- |
-
559 | -- |
- #' @param numeric_as_factor `logical` should the numeric variable be treated as a factor- |
-
560 | -- |
- #' @param dt_rows `numeric` current/latest `DT` page length- |
-
561 | -- |
- #' @param outlier_definition If 0 no outliers are removed, otherwise- |
-
562 | -- |
- #' outliers (those more than `outlier_definition*IQR below/above Q1/Q3` be removed)- |
-
563 | -- |
- #' @return text with simple statistics.- |
-
564 | -- |
- #' @keywords internal- |
-
565 | -- |
- var_summary_table <- function(x, numeric_as_factor, dt_rows, outlier_definition) {- |
-
566 | -! | -
- if (is.null(dt_rows)) {- |
-
567 | -! | -
- dt_rows <- 10- |
-
568 | -- |
- }- |
-
569 | -! | -
- if (is.numeric(x) && !numeric_as_factor) {- |
-
570 | -! | -
- req(!any(is.infinite(x)))- |
-
571 | -- | - - | -
572 | -! | -
- x <- remove_outliers_from(x, outlier_definition)- |
-
573 | -- | - - | -
574 | -! | -
- qvals <- round(stats::quantile(x, na.rm = TRUE, probs = c(0.25, 0.5, 0.75), type = 2), 2)- |
-
575 | -- |
- # classical central tendency measures- |
-
576 | -- | - - | -
577 | -! | -
- summary <-- |
-
578 | -! | -
- data.frame(- |
-
579 | -! | -
- Statistic = c("min", "Q1", "median", "mean", "Q3", "max", "sd", "n"),- |
-
580 | -! | -
- Value = c(- |
-
581 | -! | -
- round(min(x, na.rm = TRUE), 2),- |
-
582 | -! | -
- qvals[1],- |
-
583 | -! | -
- qvals[2],- |
-
584 | -! | -
- round(mean(x, na.rm = TRUE), 2),- |
-
585 | -! | -
- qvals[3],- |
-
586 | -! | -
- round(max(x, na.rm = TRUE), 2),- |
-
587 | -! | -
- round(stats::sd(x, na.rm = TRUE), 2),- |
-
588 | -! | -
- length(x[!is.na(x)])- |
-
589 | -- |
- )- |
-
590 | -- |
- )- |
-
591 | -- | - - | -
592 | -! | -
- DT::datatable(summary, rownames = FALSE, options = list(dom = "<t>", pageLength = dt_rows))- |
-
593 | -! | -
- } else if (is.factor(x) || is.character(x) || (is.numeric(x) && numeric_as_factor) || is.logical(x)) {- |
-
594 | -- |
- # make sure factor is ordered numeric- |
-
595 | -! | -
- if (is.numeric(x)) {- |
-
596 | -! | -
- x <- factor(x, levels = sort(unique(x)))- |
-
597 | -- |
- }- |
-
598 | -- | - - | -
599 | -! | -
- level_counts <- table(x)- |
-
600 | -! | -
- max_levels_signif <- nchar(level_counts)- |
-
601 | -- | - - | -
602 | -! | -
- if (!all(is.na(x))) {- |
-
603 | -! | -
- levels <- names(level_counts)- |
-
604 | -! | -
- counts <- sprintf(- |
-
605 | -! | -
- "%s [%.2f%%]",- |
-
606 | -! | -
- format(level_counts, width = max_levels_signif), prop.table(level_counts) * 100- |
-
607 | -- |
- )- |
-
608 | -- |
- } else {- |
-
609 | -! | -
- levels <- character(0)- |
-
610 | -! | -
- counts <- numeric(0)- |
-
611 | -- |
- }- |
-
612 | -- | - - | -
613 | -! | -
- summary <- data.frame(- |
-
614 | -! | -
- Level = levels,- |
-
615 | -! | -
- Count = counts,- |
-
616 | -! | -
- stringsAsFactors = FALSE- |
-
617 | -- |
- )- |
-
618 | -- | - - | -
619 | -- |
- # sort the dataset in decreasing order of counts (needed as character variables default to alphabetical)- |
-
620 | -! | -
- summary <- summary[order(summary$Count, decreasing = TRUE), ]- |
-
621 | -- | - - | -
622 | -! | -
- dom_opts <- if (nrow(summary) <= 10) {- |
-
623 | -! | -
- "<t>"- |
-
624 | -- |
- } else {- |
-
625 | -! | -
- "<lf<t>ip>"- |
-
626 | -- |
- }- |
-
627 | -! | -
- DT::datatable(summary, rownames = FALSE, options = list(dom = dom_opts, pageLength = dt_rows))- |
-
628 | -! | -
- } else if (inherits(x, "Date") || inherits(x, "POSIXct") || inherits(x, "POSIXlt")) {- |
-
629 | -! | -
- summary <-- |
-
630 | -! | -
- data.frame(- |
-
631 | -! | -
- Statistic = c("min", "median", "max"),- |
-
632 | -! | -
- Value = c(- |
-
633 | -! | -
- min(x, na.rm = TRUE),- |
-
634 | -! | -
- stats::median(x, na.rm = TRUE),- |
-
635 | -! | -
- max(x, na.rm = TRUE)- |
-
636 | -- |
- )- |
-
637 | -- |
- )- |
-
638 | -! | -
- DT::datatable(summary, rownames = FALSE, options = list(dom = "<t>", pageLength = dt_rows))- |
-
639 | -- |
- } else {- |
-
640 | -! | -
- NULL- |
-
641 | -- |
- }- |
-
642 | -- |
- }- |
-
643 | -- | - - | -
644 | -- |
- #' Plot variable- |
-
645 | -- |
- #'- |
-
646 | -- |
- #' Creates summary plot with statistics relevant to data type.- |
-
647 | -- |
- #'- |
-
648 | -- |
- #' @inheritParams shared_params- |
-
649 | -- |
- #' @param var vector of any type to be plotted. For numeric variables it produces histogram with- |
-
650 | -- |
- #' density line, for factors it creates frequency plot- |
-
651 | -- |
- #' @param var_lab text describing selected variable to be displayed on the plot- |
-
652 | -- |
- #' @param wrap_character (`numeric`) number of characters at which to wrap text values of `var`- |
-
653 | -- |
- #' @param numeric_as_factor (`logical`) should the numeric variable be treated as a factor- |
-
654 | -- |
- #' @param display_density (`logical`) should density estimation be displayed for numeric values- |
-
655 | -- |
- #' @param remove_NA_hist (`logical`) should `NA` values be removed for histogram of factor like variables- |
-
656 | -- |
- #' @param outlier_definition if 0 no outliers are removed, otherwise- |
-
657 | -- |
- #' outliers (those more than outlier_definition*IQR below/above Q1/Q3 be removed)- |
-
658 | -- |
- #' @param records_for_factor (`numeric`) if the number of factor levels is >= than this value then- |
-
659 | -- |
- #' a graph of the factors isn't shown, only a list of values- |
-
660 | -- |
- #'- |
-
661 | -- |
- #' @return plot- |
-
662 | -- |
- #' @keywords internal- |
-
663 | -- |
- plot_var_summary <- function(var,- |
-
664 | -- |
- var_lab,- |
-
665 | -- |
- wrap_character = NULL,- |
-
666 | -- |
- numeric_as_factor,- |
-
667 | -- |
- display_density = is.numeric(var),- |
-
668 | -- |
- remove_NA_hist = FALSE, # nolint: object_name.- |
-
669 | -- |
- outlier_definition,- |
-
670 | -- |
- records_for_factor,- |
-
671 | -- |
- ggplot2_args) {- |
-
672 | -! | -
- checkmate::assert_character(var_lab)- |
-
673 | -! | -
- checkmate::assert_numeric(wrap_character, null.ok = TRUE)- |
-
674 | -! | -
- checkmate::assert_flag(numeric_as_factor)- |
-
675 | -! | -
- checkmate::assert_flag(display_density)- |
-
676 | -! | -
- checkmate::assert_logical(remove_NA_hist, null.ok = TRUE)- |
-
677 | -! | -
- checkmate::assert_number(outlier_definition, lower = 0, finite = TRUE)- |
-
678 | -! | -
- checkmate::assert_integerish(records_for_factor, lower = 0, len = 1, any.missing = FALSE)- |
-
679 | -! | -
- checkmate::assert_class(ggplot2_args, "ggplot2_args")- |
-
680 | -- | - - | -
681 | -! | -
- grid::grid.newpage()- |
-
682 | -- | - - | -
683 | -! | -
- plot_main <- if (is.factor(var) || is.character(var) || is.logical(var)) {- |
-
684 | -! | -
- groups <- unique(as.character(var))- |
-
685 | -! | -
- len_groups <- length(groups)- |
-
686 | -! | -
- if (len_groups >= records_for_factor) {- |
-
687 | -! | -
- grid::textGrob(- |
-
688 | -! | -
- sprintf(- |
-
689 | -! | -
- "%s unique values\n%s:\n %s\n ...\n %s",- |
-
690 | -! | -
- len_groups,- |
-
691 | -! | -
- var_lab,- |
-
692 | -! | -
- paste(utils::head(groups), collapse = ",\n "),- |
-
693 | -! | -
- paste(utils::tail(groups), collapse = ",\n ")- |
-
694 | -- |
- ),- |
-
695 | -! | -
- x = grid::unit(1, "line"),- |
-
696 | -! | -
- y = grid::unit(1, "npc") - grid::unit(1, "line"),- |
-
697 | -! | -
- just = c("left", "top")- |
-
698 | -- |
- )- |
-
699 | -- |
- } else {- |
-
700 | -! | -
- if (!is.null(wrap_character)) {- |
-
701 | -! | -
- var <- stringr::str_wrap(var, width = wrap_character)- |
-
702 | -- |
- }- |
-
703 | -! | -
- var <- if (isTRUE(remove_NA_hist)) as.vector(stats::na.omit(var)) else var- |
-
704 | -! | -
- ggplot(data.frame(var), aes(x = forcats::fct_infreq(as.factor(var)))) +- |
-
705 | -! | -
- geom_bar(stat = "count", aes(fill = ifelse(is.na(var), "withcolor", "")), show.legend = FALSE) +- |
-
706 | -! | -
- scale_fill_manual(values = c("gray50", "tan"))- |
-
707 | -- |
- }- |
-
708 | -! | -
- } else if (is.numeric(var)) {- |
-
709 | -! | -
- validate(need(any(!is.na(var)), "No data left to visualize."))- |
-
710 | -- | - - | -
711 | -- |
- # Filter out NA- |
-
712 | -! | -
- var <- var[which(!is.na(var))]- |
-
713 | -- | - - | -
714 | -! | -
- validate(need(!any(is.infinite(var)), "Cannot display graph when data includes infinite values"))- |
-
715 | -- | - - | -
716 | -! | -
- if (numeric_as_factor) {- |
-
717 | -! | -
- var <- factor(var)- |
-
718 | -! | -
- ggplot(NULL, aes(x = var)) +- |
-
719 | -! | -
- geom_histogram(stat = "count")- |
-
720 | -- |
- } else {- |
-
721 | -- |
- # remove outliers- |
-
722 | -! | -
- if (outlier_definition != 0) {- |
-
723 | -! | -
- number_records <- length(var)- |
-
724 | -! | -
- var <- remove_outliers_from(var, outlier_definition)- |
-
725 | -! | -
- number_outliers <- number_records - length(var)- |
-
726 | -! | -
- outlier_text <- paste0(- |
-
727 | -! | -
- number_outliers, " outliers (",- |
-
728 | -! | -
- round(number_outliers / number_records * 100, 2),- |
-
729 | -! | -
- "% of non-missing records) not shown"- |
-
730 | -- |
- )- |
-
731 | -! | -
- validate(need(- |
-
732 | -! | -
- length(var) > 1,- |
-
733 | -! | -
- "At least two data points must remain after removing outliers for this graph to be displayed"- |
-
734 | -- |
- ))- |
-
735 | -- |
- }- |
-
736 | -- |
- ## histogram- |
-
737 | -! | -
- binwidth <- get_bin_width(var)- |
-
738 | -! | -
- p <- ggplot(data = data.frame(var = var), aes(x = var, y = after_stat(count))) +- |
-
739 | -! | -
- geom_histogram(binwidth = binwidth) +- |
-
740 | -! | -
- scale_y_continuous(- |
-
741 | -! | -
- sec.axis = sec_axis(- |
-
742 | -! | -
- trans = ~ . / nrow(data.frame(var = var)),- |
-
743 | -! | -
- labels = scales::percent,- |
-
744 | -! | -
- name = "proportion (in %)"- |
-
745 | -- |
- )- |
-
746 | -- |
- )- |
-
747 | -- | - - | -
748 | -! | -
- if (display_density) {- |
-
749 | -! | -
- p <- p + geom_density(aes(y = after_stat(count * binwidth)))- |
-
750 | -- |
- }- |
-
751 | -- | - - | -
752 | -! | -
- if (outlier_definition != 0) {- |
-
753 | -! | -
- p <- p + annotate(- |
-
754 | -! | -
- geom = "text",- |
-
755 | -! | -
- label = outlier_text,- |
-
756 | -! | -
- x = Inf, y = Inf,- |
-
757 | -! | -
- hjust = 1.02, vjust = 1.2,- |
-
758 | -! | -
- color = "black",- |
-
759 | -- |
- # explicitly modify geom text size according- |
-
760 | -! | -
- size = ggplot2_args[["theme"]][["text"]][["size"]] / 3.5- |
-
761 | -- |
- )- |
-
762 | -- |
- }- |
-
763 | -! | -
- p- |
-
764 | -- |
- }- |
-
765 | -! | -
- } else if (inherits(var, "Date") || inherits(var, "POSIXct") || inherits(var, "POSIXlt")) {- |
-
766 | -! | -
- var_num <- as.numeric(var)- |
-
767 | -! | -
- binwidth <- get_bin_width(var_num, 1)- |
-
768 | -! | -
- p <- ggplot(data = data.frame(var = var), aes(x = var, y = after_stat(count))) +- |
-
769 | -! | -
- geom_histogram(binwidth = binwidth)- |
-
770 | -- |
- } else {- |
-
771 | -! | -
- grid::textGrob(- |
-
772 | -! | -
- paste(strwrap(- |
-
773 | -! | -
- utils::capture.output(utils::str(var)),- |
-
774 | -! | -
- width = .9 * grid::convertWidth(grid::unit(1, "npc"), "char", TRUE)- |
-
775 | -! | -
- ), collapse = "\n"),- |
-
776 | -! | -
- x = grid::unit(1, "line"), y = grid::unit(1, "npc") - grid::unit(1, "line"), just = c("left", "top")- |
-
777 | -- |
- )- |
-
778 | -- |
- }- |
-
779 | -- | - - | -
780 | -! | -
- dev_ggplot2_args <- teal.widgets::ggplot2_args(- |
-
781 | -! | -
- labs = list(x = var_lab)- |
-
782 | -- |
- )- |
-
783 | -- |
- ###- |
-
784 | -! | -
- all_ggplot2_args <- teal.widgets::resolve_ggplot2_args(- |
-
785 | -! | -
- ggplot2_args,- |
-
786 | -! | -
- module_plot = dev_ggplot2_args- |
-
787 | -- |
- )- |
-
788 | -- | - - | -
789 | -! | -
- if (is.ggplot(plot_main)) {- |
-
790 | -! | -
- if (is.numeric(var) && !numeric_as_factor) {- |
-
791 | -- |
- # numeric not as factor- |
-
792 | -! | -
- plot_main <- plot_main +- |
-
793 | -! | -
- theme_light() +- |
-
794 | -! | -
- list(- |
-
795 | -! | -
- labs = do.call("labs", all_ggplot2_args$labs),- |
-
796 | -! | -
- theme = do.call("theme", all_ggplot2_args$theme)- |
-
797 | -- |
- )- |
-
798 | -- |
- } else {- |
-
799 | -- |
- # factor low number of levels OR numeric as factor OR Date- |
-
800 | -! | -
- plot_main <- plot_main +- |
-
801 | -! | -
- theme_light() +- |
-
802 | -! | -
- list(- |
-
803 | -! | -
- labs = do.call("labs", all_ggplot2_args$labs),- |
-
804 | -! | -
- theme = do.call("theme", all_ggplot2_args$theme)- |
-
805 | -- |
- )- |
-
806 | -- |
- }- |
-
807 | -! | -
- plot_main <- ggplotGrob(plot_main)- |
-
808 | -- |
- }- |
-
809 | -- | - - | -
810 | -! | -
- grid::grid.draw(plot_main)- |
-
811 | -! | -
- plot_main- |
-
812 | -- |
- }- |
-
813 | -- | - - | -
814 | -- |
- is_num_var_short <- function(.unique_records_for_factor, input, data_for_analysis) {- |
-
815 | -! | -
- length(unique(data_for_analysis()$data)) < .unique_records_for_factor && !is.null(input$numeric_as_factor)- |
-
816 | -- |
- }- |
-
817 | -- | - - | -
818 | -- |
- #' Validates the variable browser inputs- |
-
819 | -- |
- #'- |
-
820 | -- |
- #' @param input (`session$input`) the `shiny` session input- |
-
821 | -- |
- #' @param plot_var (`list`) list of a data frame and an array of variable names- |
-
822 | -- |
- #' @param data (`teal_data`) the datasets passed to the module- |
-
823 | -- |
- #'- |
-
824 | -- |
- #' @returns `logical` TRUE if validations pass; a `shiny` validation error otherwise- |
-
825 | -- |
- #' @keywords internal- |
-
826 | -- |
- validate_input <- function(input, plot_var, data) {- |
-
827 | -! | -
- reactive({- |
-
828 | -! | -
- dataset_name <- req(input$tabset_panel)- |
-
829 | -! | -
- varname <- plot_var$variable[[dataset_name]]- |
-
830 | -- | - - | -
831 | -! | -
- validate(need(dataset_name, "No data selected"))- |
-
832 | -! | -
- validate(need(varname, "No variable selected"))- |
-
833 | -! | -
- df <- data()[[dataset_name]]- |
-
834 | -! | -
- teal::validate_has_data(df, 1)- |
-
835 | -! | -
- teal::validate_has_variable(varname = varname, data = df, "Variable not available")- |
-
836 | -- | - - | -
837 | -! | -
- TRUE- |
-
838 | -- |
- })- |
-
839 | -- |
- }- |
-
840 | -- | - - | -
841 | -- |
- get_plotted_data <- function(input, plot_var, data) {- |
-
842 | -! | -
- dataset_name <- input$tabset_panel- |
-
843 | -! | -
- varname <- plot_var$variable[[dataset_name]]- |
-
844 | -! | -
- df <- data()[[dataset_name]]- |
-
845 | -- | - - | -
846 | -! | -
- var_description <- teal.data::col_labels(df)[[varname]]- |
-
847 | -! | -
- list(data = df[[varname]], var_description = var_description)- |
-
848 | -- |
- }- |
-
849 | -- | - - | -
850 | -- |
- #' Renders the left-hand side `tabset` panel of the module- |
-
851 | -- |
- #'- |
-
852 | -- |
- #' @param datanames (`character`) the name of the dataset- |
-
853 | -- |
- #' @param parent_dataname (`character`) the name of a parent `dataname` to filter out variables from- |
-
854 | -- |
- #' @param data (`teal_data`) the object containing all datasets- |
-
855 | -- |
- #' @param input (`session$input`) the `shiny` session input- |
-
856 | -- |
- #' @param output (`session$output`) the `shiny` session output- |
-
857 | -- |
- #' @param columns_names (`environment`) the environment containing bindings for each dataset- |
-
858 | -- |
- #' @param plot_var (`list`) the list containing the currently selected dataset (tab) and its column names- |
-
859 | -- |
- #' @keywords internal- |
-
860 | -- |
- render_tabset_panel_content <- function(datanames, parent_dataname, output, data, input, columns_names, plot_var) {- |
-
861 | -! | -
- lapply(datanames, render_single_tab,- |
-
862 | -! | -
- input = input,- |
-
863 | -! | -
- output = output,- |
-
864 | -! | -
- data = data,- |
-
865 | -! | -
- parent_dataname = parent_dataname,- |
-
866 | -! | -
- columns_names = columns_names,- |
-
867 | -! | -
- plot_var = plot_var- |
-
868 | -- |
- )- |
-
869 | -- |
- }- |
-
870 | -- | - - | -
871 | -- |
- #' Renders a single tab in the left-hand side tabset panel- |
-
872 | -- |
- #'- |
-
873 | -- |
- #' Renders a single tab in the left-hand side tabset panel. The rendered tab contains- |
-
874 | -- |
- #' information about one dataset out of many presented in the module.- |
-
875 | -- |
- #'- |
-
876 | -- |
- #' @param dataset_name (`character`) the name of the dataset contained in the rendered tab- |
-
877 | -- |
- #' @param parent_dataname (`character`) the name of a parent `dataname` to filter out variables from- |
-
878 | -- |
- #' @inheritParams render_tabset_panel_content- |
-
879 | -- |
- #' @keywords internal- |
-
880 | -- |
- render_single_tab <- function(dataset_name, parent_dataname, output, data, input, columns_names, plot_var) {- |
-
881 | -! | -
- render_tab_header(dataset_name, output, data)- |
-
882 | -- | - - | -
883 | -! | -
- render_tab_table(- |
-
884 | -! | -
- dataset_name = dataset_name,- |
-
885 | -! | -
- parent_dataname = parent_dataname,- |
-
886 | -! | -
- output = output,- |
-
887 | -! | -
- data = data,- |
-
888 | -! | -
- input = input,- |
-
889 | -! | -
- columns_names = columns_names,- |
-
890 | -! | -
- plot_var = plot_var- |
-
891 | -- |
- )- |
-
892 | -- |
- }- |
-
893 | -- | - - | -
894 | -- |
- #' Renders the text headlining a single tab in the left-hand side tabset panel- |
-
895 | -- |
- #'- |
-
896 | -- |
- #' @param dataset_name (`character`) the name of the dataset of the tab- |
-
897 | -- |
- #' @inheritParams render_tabset_panel_content- |
-
898 | -- |
- #' @keywords internal- |
-
899 | -- |
- render_tab_header <- function(dataset_name, output, data) {- |
-
900 | -! | -
- dataset_ui_id <- paste0("dataset_summary_", dataset_name)- |
-
901 | -! | -
- output[[dataset_ui_id]] <- renderText({- |
-
902 | -! | -
- df <- data()[[dataset_name]]- |
-
903 | -! | -
- join_keys <- join_keys(data())- |
-
904 | -! | -
- if (!is.null(join_keys)) {- |
-
905 | -! | -
- key <- join_keys(data())[dataset_name, dataset_name]- |
-
906 | -- |
- } else {- |
-
907 | -! | -
- key <- NULL- |
-
908 | -- |
- }- |
-
909 | -! | -
- sprintf(- |
-
910 | -! | -
- "Dataset with %s unique key rows and %s variables",- |
-
911 | -! | -
- nrow(unique(`if`(length(key) > 0, df[, key, drop = FALSE], df))),- |
-
912 | -! | -
- ncol(df)- |
-
913 | -- |
- )- |
-
914 | -- |
- })- |
-
915 | -- |
- }- |
-
916 | -- | - - | -
917 | -- |
- #' Renders the table for a single dataset in the left-hand side tabset panel- |
-
918 | -- |
- #'- |
-
919 | -- |
- #' The table contains column names, column labels,- |
-
920 | -- |
- #' small summary about NA values and `sparkline` (if appropriate).- |
-
921 | -- |
- #'- |
-
922 | -- |
- #' @param dataset_name (`character`) the name of the dataset- |
-
923 | -- |
- #' @param parent_dataname (`character`) the name of a parent `dataname` to filter out variables from- |
-
924 | -- |
- #' @inheritParams render_tabset_panel_content- |
-
925 | -- |
- #' @keywords internal- |
-
926 | -- |
- render_tab_table <- function(dataset_name, parent_dataname, output, data, input, columns_names, plot_var) {- |
-
927 | -! | -
- table_ui_id <- paste0("variable_browser_", dataset_name)- |
-
928 | -- | - - | -
929 | -! | -
- output[[table_ui_id]] <- DT::renderDataTable({- |
-
930 | -! | -
- df <- data()[[dataset_name]]- |
-
931 | -- | - - | -
932 | -! | -
- get_vars_df <- function(input, dataset_name, parent_name, data) {- |
-
933 | -! | -
- data_cols <- colnames(df)- |
-
934 | -! | -
- if (isTRUE(input$show_parent_vars)) {- |
-
935 | -! | -
- data_cols- |
-
936 | -! | -
- } else if (dataset_name != parent_name && parent_name %in% names(data)) {- |
-
937 | -! | -
- setdiff(data_cols, colnames(data()[[parent_name]]))- |
-
938 | -- |
- } else {- |
-
939 | -! | -
- data_cols- |
-
940 | -- |
- }- |
-
941 | -- |
- }- |
-
942 | -- | - - | -
943 | -! | -
- if (length(parent_dataname) > 0) {- |
-
944 | -! | -
- df_vars <- get_vars_df(input, dataset_name, parent_dataname, data)- |
-
945 | -! | -
- df <- df[df_vars]- |
-
946 | -- |
- }- |
-
947 | -- | - - | -
948 | -! | -
- if (is.null(df) || ncol(df) == 0) {- |
-
949 | -! | -
- columns_names[[dataset_name]] <- character(0)- |
-
950 | -! | -
- df_output <- data.frame(- |
-
951 | -! | -
- Type = character(0),- |
-
952 | -! | -
- Variable = character(0),- |
-
953 | -! | -
- Label = character(0),- |
-
954 | -! | -
- Missings = character(0),- |
-
955 | -! | -
- Sparklines = character(0),- |
-
956 | -! | -
- stringsAsFactors = FALSE- |
-
957 | -- |
- )- |
-
958 | -- |
- } else {- |
-
959 | -- |
- # extract data variable labels- |
-
960 | -! | -
- labels <- teal.data::col_labels(df)- |
-
961 | -- | - - | -
962 | -! | -
- columns_names[[dataset_name]] <- names(labels)- |
-
963 | -- | - - | -
964 | -- |
- # calculate number of missing values- |
-
965 | -! | -
- missings <- vapply(- |
-
966 | -! | -
- df,- |
-
967 | -! | -
- var_missings_info,- |
-
968 | -! | -
- FUN.VALUE = character(1),- |
-
969 | -! | -
- USE.NAMES = FALSE- |
-
970 | -- |
- )- |
-
971 | -- | - - | -
972 | -- |
- # get icons proper for the data types- |
-
973 | -! | -
- icons <- vapply(df, function(x) class(x)[1L], character(1L))- |
-
974 | -- | - - | -
975 | -! | -
- join_keys <- join_keys(data())- |
-
976 | -! | -
- if (!is.null(join_keys)) {- |
-
977 | -! | -
- icons[intersect(join_keys[dataset_name, dataset_name], colnames(df))] <- "primary_key"- |
-
978 | -- |
- }- |
-
979 | -! | -
- icons <- variable_type_icons(icons)- |
-
980 | -- | - - | -
981 | -- |
- # generate sparklines- |
-
982 | -! | -
- sparklines_html <- vapply(- |
-
983 | -! | -
- df,- |
-
984 | -! | -
- create_sparklines,- |
-
985 | -! | -
- FUN.VALUE = character(1),- |
-
986 | -! | -
- USE.NAMES = FALSE- |
-
987 | -- |
- )- |
-
988 | -- | - - | -
989 | -! | -
- df_output <- data.frame(- |
-
990 | -! | -
- Type = icons,- |
-
991 | -! | -
- Variable = names(labels),- |
-
992 | -! | -
- Label = labels,- |
-
993 | -! | -
- Missings = missings,- |
-
994 | -! | -
- Sparklines = sparklines_html,- |
-
995 | -! | -
- stringsAsFactors = FALSE- |
-
996 | -- |
- )- |
-
997 | -- |
- }- |
-
998 | -- | - - | -
999 | -- |
- # Select row 1 as default / fallback- |
-
1000 | -! | -
- selected_ix <- 1- |
-
1001 | -- |
- # Define starting page index (base-0 index of the first item on page- |
-
1002 | -- |
- # note: in many cases it's not the item itself- |
-
1003 | -! | -
- selected_page_ix <- 0- |
-
1004 | -- | - - | -
1005 | -- |
- # Retrieve current selected variable if any- |
-
1006 | -! | -
- isolated_variable <- shiny::isolate(plot_var$variable[[dataset_name]])- |
-
1007 | -- | - - | -
1008 | -! | -
- if (!is.null(isolated_variable)) {- |
-
1009 | -! | -
- index <- which(columns_names[[dataset_name]] == isolated_variable)[1]- |
-
1010 | -! | -
- if (!is.null(index) && !is.na(index) && length(index) > 0) selected_ix <- index- |
-
1011 | -- |
- }- |
-
1012 | -- | - - | -
1013 | -- |
- # Retrieve the index of the first item of the current page- |
-
1014 | -- |
- # it works with varying number of entries on the page (10, 25, ...)- |
-
1015 | -! | -
- table_id_sel <- paste0("variable_browser_", dataset_name, "_state")- |
-
1016 | -! | -
- dt_state <- shiny::isolate(input[[table_id_sel]])- |
-
1017 | -! | -
- if (selected_ix != 1 && !is.null(dt_state)) {- |
-
1018 | -! | -
- selected_page_ix <- floor(selected_ix / dt_state$length) * dt_state$length- |
-
1019 | -- |
- }- |
-
1020 | -- | - - | -
1021 | -! | -
- DT::datatable(- |
-
1022 | -! | -
- df_output,- |
-
1023 | -! | -
- escape = FALSE,- |
-
1024 | -! | -
- rownames = FALSE,- |
-
1025 | -! | -
- selection = list(mode = "single", target = "row", selected = selected_ix),- |
-
1026 | -! | -
- options = list(- |
-
1027 | -! | -
- fnDrawCallback = htmlwidgets::JS("function() { HTMLWidgets.staticRender(); }"),- |
-
1028 | -! | -
- pageLength = input[[paste0(table_ui_id, "_rows")]],- |
-
1029 | -! | -
- displayStart = selected_page_ix- |
-
1030 | -- |
- )- |
-
1031 | -- |
- )- |
-
1032 | -- |
- })- |
-
1033 | -- |
- }- |
-
1034 | -- | - - | -
1035 | -- |
- #' Creates observers updating the currently selected column- |
-
1036 | -- |
- #'- |
-
1037 | -- |
- #' The created observers update the column currently selected in the left-hand side- |
-
1038 | -- |
- #' tabset panel.- |
-
1039 | -- |
- #'- |
-
1040 | -- |
- #' @note- |
-
1041 | -- |
- #' Creates an observer for each dataset (each tab in the tabset panel).- |
-
1042 | -- |
- #'- |
-
1043 | -- |
- #' @inheritParams render_tabset_panel_content- |
-
1044 | -- |
- #' @keywords internal- |
-
1045 | -- |
- establish_updating_selection <- function(datanames, input, plot_var, columns_names) {- |
-
1046 | -! | -
- lapply(datanames, function(dataset_name) {- |
-
1047 | -! | -
- table_ui_id <- paste0("variable_browser_", dataset_name)- |
-
1048 | -! | -
- table_id_sel <- paste0(table_ui_id, "_rows_selected")- |
-
1049 | -! | -
- observeEvent(input[[table_id_sel]], {- |
-
1050 | -! | -
- plot_var$data <- dataset_name- |
-
1051 | -! | -
- plot_var$variable[[dataset_name]] <- columns_names[[dataset_name]][input[[table_id_sel]]]- |
-
1052 | -- |
- })- |
-
1053 | -- |
- })- |
-
1054 | -- |
- }- |
-
1055 | -- | - - | -
1056 | -- |
- get_bin_width <- function(x_vec, scaling_factor = 2) {- |
-
1057 | -! | -
- x_vec <- x_vec[!is.na(x_vec)]- |
-
1058 | -! | -
- qntls <- stats::quantile(x_vec, probs = c(0.1, 0.25, 0.75, 0.9), type = 2)- |
-
1059 | -! | -
- iqr <- qntls[3] - qntls[2]- |
-
1060 | -! | -
- binwidth <- max(scaling_factor * iqr / length(x_vec) ^ (1 / 3), sqrt(qntls[4] - qntls[1])) # styler: off- |
-
1061 | -! | -
- binwidth <- ifelse(binwidth == 0, 1, binwidth)- |
-
1062 | -- |
- # to ensure at least two bins when variable span is very small- |
-
1063 | -! | -
- x_span <- diff(range(x_vec))- |
-
1064 | -! | -
- if (isTRUE(x_span / binwidth >= 2)) binwidth else x_span / 2- |
-
1065 | -- |
- }- |
-
1066 | -- | - - | -
1067 | -- |
- #' Removes the outlier observation from an array- |
-
1068 | -- |
- #'- |
-
1069 | -- |
- #' @param var (`numeric`) a numeric vector- |
-
1070 | -- |
- #' @param outlier_definition (`numeric`) if `0` then no outliers are removed, otherwise- |
-
1071 | -- |
- #' outliers (those more than `outlier_definition*IQR below/above Q1/Q3`) are removed- |
-
1072 | -- |
- #' @returns (`numeric`) vector without the outlier values- |
-
1073 | -- |
- #' @keywords internal- |
-
1074 | -- |
- remove_outliers_from <- function(var, outlier_definition) {- |
-
1075 | -3x | -
- if (outlier_definition == 0) {- |
-
1076 | -1x | -
- return(var)- |
-
1077 | -- |
- }- |
-
1078 | -2x | -
- q1_q3 <- stats::quantile(var, probs = c(0.25, 0.75), type = 2, na.rm = TRUE)- |
-
1079 | -2x | -
- iqr <- q1_q3[2] - q1_q3[1]- |
-
1080 | -2x | -
- var[var >= q1_q3[1] - outlier_definition * iqr & var <= q1_q3[2] + outlier_definition * iqr]- |
-
1081 | -- |
- }- |
-
1082 | -- | - - | -
1083 | -- | - - | -
1084 | -- |
- # sparklines ----- |
-
1085 | -- | - - | -
1086 | -- |
- #' S3 generic for `sparkline` widget HTML- |
-
1087 | -- |
- #'- |
-
1088 | -- |
- #' Generates the `sparkline` HTML code corresponding to the input array.- |
-
1089 | -- |
- #' For numeric variables creates a box plot, for character and factors - bar plot.- |
-
1090 | -- |
- #' Produces an empty string for variables of other types.- |
-
1091 | -- |
- #'- |
-
1092 | -- |
- #' @param arr vector of any type and length- |
-
1093 | -- |
- #' @param width `numeric` the width of the `sparkline` widget (pixels)- |
-
1094 | -- |
- #' @param bar_spacing `numeric` the spacing between the bars (in pixels)- |
-
1095 | -- |
- #' @param bar_width `numeric` the width of the bars (in pixels)- |
-
1096 | -- |
- #' @param ... `list` additional options passed to bar plots of `jquery.sparkline`;- |
-
1097 | -- |
- #' see [`jquery.sparkline docs`](https://omnipotent.net/jquery.sparkline/#common)- |
-
1098 | -- |
- #'- |
-
1099 | -- |
- #' @return Character string containing HTML code of the `sparkline` HTML widget.- |
-
1100 | -- |
- #' @keywords internal- |
-
1101 | -- |
- create_sparklines <- function(arr, width = 150, ...) {- |
-
1102 | -! | -
- if (all(is.null(arr))) {- |
-
1103 | -! | -
- return("")- |
-
1104 | -- |
- }- |
-
1105 | -! | -
- UseMethod("create_sparklines")- |
-
1106 | -- |
- }- |
-
1107 | -- | - - | -
1108 | -- |
- #' @rdname create_sparklines- |
-
1109 | -- |
- #' @keywords internal- |
-
1110 | -- |
- #' @export- |
-
1111 | -- |
- create_sparklines.logical <- function(arr, ...) {- |
-
1112 | -! | -
- create_sparklines(as.factor(arr))- |
-
1113 | -- |
- }- |
-
1114 | -- | - - | -
1115 | -- |
- #' @rdname create_sparklines- |
-
1116 | -- |
- #' @keywords internal- |
-
1117 | -- |
- #' @export- |
-
1118 | -- |
- create_sparklines.numeric <- function(arr, width = 150, ...) {- |
-
1119 | -! | -
- if (any(is.infinite(arr))) {- |
-
1120 | -! | -
- return(as.character(tags$code("infinite values", class = "text-blue")))- |
-
1121 | -- |
- }- |
-
1122 | -! | -
- if (length(arr) > 100000) {- |
-
1123 | -! | -
- return(as.character(tags$code("Too many rows (>100000)", class = "text-blue")))- |
-
1124 | -- |
- }- |
-
1125 | -- | - - | -
1126 | -! | -
- arr <- arr[!is.na(arr)]- |
-
1127 | -! | -
- sparkline::spk_chr(unname(arr), type = "box", width = width, ...)- |
-
1128 | -- |
- }- |
-
1129 | -- | - - | -
1130 | -- |
- #' @rdname create_sparklines- |
-
1131 | -- |
- #' @keywords internal- |
-
1132 | -- |
- #' @export- |
-
1133 | -- |
- create_sparklines.character <- function(arr, ...) {- |
-
1134 | -! | -
- return(create_sparklines(as.factor(arr)))- |
-
1135 | -- |
- }- |
-
1136 | -- | - - | -
1137 | -- | - - | -
1138 | -- |
- #' @rdname create_sparklines- |
-
1139 | -- |
- #' @keywords internal- |
-
1140 | -- |
- #' @export- |
-
1141 | -- |
- create_sparklines.factor <- function(arr, width = 150, bar_spacing = 5, bar_width = 20, ...) {- |
-
1142 | -! | -
- decreasing_order <- TRUE- |
-
1143 | -- | - - | -
1144 | -! | -
- counts <- table(arr)- |
-
1145 | -! | -
- if (length(counts) >= 100) {- |
-
1146 | -! | -
- return(as.character(tags$code("> 99 levels", class = "text-blue")))- |
-
1147 | -! | -
- } else if (length(counts) == 0) {- |
-
1148 | -! | -
- return(as.character(tags$code("no levels", class = "text-blue")))- |
-
1149 | -! | -
- } else if (length(counts) == 1) {- |
-
1150 | -! | -
- return(as.character(tags$code("one level", class = "text-blue")))- |
-
1151 | -- |
- }- |
-
1152 | -- | - - | -
1153 | -- |
- # Summarize the occurences of different levels- |
-
1154 | -- |
- # and get the maximum and minimum number of occurences- |
-
1155 | -- |
- # This is needed for the sparkline to correctly display the bar plots- |
-
1156 | -- |
- # Otherwise they are cropped- |
-
1157 | -! | -
- counts <- sort(counts, decreasing = decreasing_order, method = "radix")- |
-
1158 | -! | -
- max_value <- if (decreasing_order) counts[1] else counts[length[counts]]- |
-
1159 | -! | -
- max_value <- unname(max_value)- |
-
1160 | -- | - - | -
1161 | -! | -
- sparkline::spk_chr(- |
-
1162 | -! | -
- unname(counts),- |
-
1163 | -! | -
- type = "bar",- |
-
1164 | -! | -
- chartRangeMin = 0,- |
-
1165 | -! | -
- chartRangeMax = max_value,- |
-
1166 | -! | -
- width = width,- |
-
1167 | -! | -
- barWidth = bar_width,- |
-
1168 | -! | -
- barSpacing = bar_spacing,- |
-
1169 | -! | -
- tooltipFormatter = custom_sparkline_formatter(names(counts), as.vector(counts))- |
-
1170 | -- |
- )- |
-
1171 | -- |
- }- |
-
1172 | -- | - - | -
1173 | -- |
- #' @rdname create_sparklines- |
-
1174 | -- |
- #' @keywords internal- |
-
1175 | -- |
- #' @export- |
-
1176 | -- |
- create_sparklines.Date <- function(arr, width = 150, bar_spacing = 5, bar_width = 20, ...) {- |
-
1177 | -! | -
- arr_num <- as.numeric(arr)- |
-
1178 | -! | -
- arr_num <- sort(arr_num, decreasing = FALSE, method = "radix")- |
-
1179 | -! | -
- binwidth <- get_bin_width(arr_num, 1)- |
-
1180 | -! | -
- bins <- floor(diff(range(arr_num)) / binwidth) + 1- |
-
1181 | -! | -
- if (all(is.na(bins))) {- |
-
1182 | -! | -
- return(as.character(tags$code("only NA", class = "text-blue")))- |
-
1183 | -! | -
- } else if (bins == 1) {- |
-
1184 | -! | -
- return(as.character(tags$code("one date", class = "text-blue")))- |
-
1185 | -- |
- }- |
-
1186 | -! | -
- counts <- as.vector(unname(base::table(cut(arr_num, breaks = bins))))- |
-
1187 | -! | -
- max_value <- max(counts)- |
-
1188 | -- | - - | -
1189 | -! | -
- start_bins <- as.integer(seq(1, length(arr_num), length.out = bins))- |
-
1190 | -! | -
- labels_start <- as.character(as.Date(arr_num[start_bins], origin = as.Date("1970-01-01")))- |
-
1191 | -! | -
- labels <- paste("Start:", labels_start)- |
-
1192 | -- | - - | -
1193 | -! | -
- sparkline::spk_chr(- |
-
1194 | -! | -
- unname(counts),- |
-
1195 | -! | -
- type = "bar",- |
-
1196 | -! | -
- chartRangeMin = 0,- |
-
1197 | -! | -
- chartRangeMax = max_value,- |
-
1198 | -! | -
- width = width,- |
-
1199 | -! | -
- barWidth = bar_width,- |
-
1200 | -! | -
- barSpacing = bar_spacing,- |
-
1201 | -! | -
- tooltipFormatter = custom_sparkline_formatter(labels, counts)- |
-
1202 | -- |
- )- |
-
1203 | -- |
- }- |
-
1204 | -- | - - | -
1205 | -- |
- #' @rdname create_sparklines- |
-
1206 | -- |
- #' @keywords internal- |
-
1207 | -- |
- #' @export- |
-
1208 | -- |
- create_sparklines.POSIXct <- function(arr, width = 150, bar_spacing = 5, bar_width = 20, ...) {- |
-
1209 | -! | -
- arr_num <- as.numeric(arr)- |
-
1210 | -! | -
- arr_num <- sort(arr_num, decreasing = FALSE, method = "radix")- |
-
1211 | -! | -
- binwidth <- get_bin_width(arr_num, 1)- |
-
1212 | -! | -
- bins <- floor(diff(range(arr_num)) / binwidth) + 1- |
-
1213 | -! | -
- if (all(is.na(bins))) {- |
-
1214 | -! | -
- return(as.character(tags$code("only NA", class = "text-blue")))- |
-
1215 | -! | -
- } else if (bins == 1) {- |
-
1216 | -! | -
- return(as.character(tags$code("one date-time", class = "text-blue")))- |
-
1217 | -- |
- }- |
-
1218 | -! | -
- counts <- as.vector(unname(base::table(cut(arr_num, breaks = bins))))- |
-
1219 | -! | -
- max_value <- max(counts)- |
-
1220 | -- | - - | -
1221 | -! | -
- start_bins <- as.integer(seq(1, length(arr_num), length.out = bins))- |
-
1222 | -! | -
- labels_start <- as.character(format(as.POSIXct(arr_num[start_bins], origin = as.Date("1970-01-01")), "%Y-%m-%d"))- |
-
1223 | -! | -
- labels <- paste("Start:", labels_start)- |
-
1224 | -- | - - | -
1225 | -! | -
- sparkline::spk_chr(- |
-
1226 | -! | -
- unname(counts),- |
-
1227 | -! | -
- type = "bar",- |
-
1228 | -! | -
- chartRangeMin = 0,- |
-
1229 | -! | -
- chartRangeMax = max_value,- |
-
1230 | -! | -
- width = width,- |
-
1231 | -! | -
- barWidth = bar_width,- |
-
1232 | -! | -
- barSpacing = bar_spacing,- |
-
1233 | -! | -
- tooltipFormatter = custom_sparkline_formatter(labels, counts)- |
-
1234 | -- |
- )- |
-
1235 | -- |
- }- |
-
1236 | -- | - - | -
1237 | -- |
- #' @rdname create_sparklines- |
-
1238 | -- |
- #' @keywords internal- |
-
1239 | -- |
- #' @export- |
-
1240 | -- |
- create_sparklines.POSIXlt <- function(arr, width = 150, bar_spacing = 5, bar_width = 20, ...) {- |
-
1241 | -! | -
- arr_num <- as.numeric(arr)- |
-
1242 | -! | -
- arr_num <- sort(arr_num, decreasing = FALSE, method = "radix")- |
-
1243 | -! | -
- binwidth <- get_bin_width(arr_num, 1)- |
-
1244 | -! | -
- bins <- floor(diff(range(arr_num)) / binwidth) + 1- |
-
1245 | -! | -
- if (all(is.na(bins))) {- |
-
1246 | -! | -
- return(as.character(tags$code("only NA", class = "text-blue")))- |
-
1247 | -! | -
- } else if (bins == 1) {- |
-
1248 | -! | -
- return(as.character(tags$code("one date-time", class = "text-blue")))- |
-
1249 | -- |
- }- |
-
1250 | -! | -
- counts <- as.vector(unname(base::table(cut(arr_num, breaks = bins))))- |
-
1251 | -! | -
- max_value <- max(counts)- |
-
1252 | -- | - - | -
1253 | -! | -
- start_bins <- as.integer(seq(1, length(arr_num), length.out = bins))- |
-
1254 | -! | -
- labels_start <- as.character(format(as.POSIXct(arr_num[start_bins], origin = as.Date("1970-01-01")), "%Y-%m-%d"))- |
-
1255 | -! | -
- labels <- paste("Start:", labels_start)- |
-
1256 | -- | - - | -
1257 | -! | -
- sparkline::spk_chr(- |
-
1258 | -! | -
- unname(counts),- |
-
1259 | -! | -
- type = "bar",- |
-
1260 | -! | -
- chartRangeMin = 0,- |
-
1261 | -! | -
- chartRangeMax = max_value,- |
-
1262 | -! | -
- width = width,- |
-
1263 | -! | -
- barWidth = bar_width,- |
-
1264 | -! | -
- barSpacing = bar_spacing,- |
-
1265 | -! | -
- tooltipFormatter = custom_sparkline_formatter(labels, counts)- |
-
1266 | -- |
- )- |
-
1267 | -- |
- }- |
-
1268 | -- | - - | -
1269 | -- |
- #' @rdname create_sparklines- |
-
1270 | -- |
- #' @keywords internal- |
-
1271 | -- |
- #' @export- |
-
1272 | -- |
- create_sparklines.default <- function(arr, width = 150, ...) {- |
-
1273 | -! | -
- as.character(tags$code("unsupported variable type", class = "text-blue"))- |
-
1274 | -- |
- }- |
-
1275 | -- | - - | -
1276 | -- | - - | -
1277 | -- |
- custom_sparkline_formatter <- function(labels, counts) {- |
-
1278 | -! | -
- htmlwidgets::JS(- |
-
1279 | -! | -
- sprintf(- |
-
1280 | -! | -
- "function(sparkline, options, field) {- |
-
1281 | -! | -
- return 'ID: ' + %s[field[0].offset] + '<br>' + 'Count: ' + %s[field[0].offset];- |
-
1282 | -- |
- }",- |
-
1283 | -! | -
- jsonlite::toJSON(labels),- |
-
1284 | -! | -
- jsonlite::toJSON(counts)- |
-
1285 | -- |
- )- |
-
1286 | -- |
- )- |
-
1287 | -- |
- }- |
-
1 | -- |
- #' `teal` module: Missing data analysis- |
-
2 | -- |
- #'- |
-
3 | -- |
- #' This module analyzes missing data in `data.frame`s to help users explore missing observations and- |
-
4 | -- |
- #' gain insights into the completeness of their data.- |
-
5 | -- |
- #' It is useful for clinical data analysis within the context of `CDISC` standards and- |
-
6 | -- |
- #' adaptable for general data analysis purposes.- |
-
7 | -- |
- #'- |
-
8 | -- |
- #' @inheritParams teal::module- |
-
9 | -- |
- #' @inheritParams shared_params- |
-
10 | -- |
- #' @param parent_dataname (`character(1)`) Specifies the parent dataset name. Default is `ADSL` for `CDISC` data.- |
-
11 | -- |
- #' If provided and exists, enables additional analysis "by subject". For non-`CDISC` data, this parameter can be- |
-
12 | -- |
- #' ignored.- |
-
13 | -- |
- #' @param ggtheme (`character`) optional, specifies the default `ggplot2` theme for plots. Defaults to `classic`.- |
-
14 | -- |
- #'- |
-
15 | -- |
- #' @templateVar ggnames "Summary Obs", "Summary Patients", "Combinations Main", "Combinations Hist", "By Subject"- |
-
16 | -- |
- #' @template ggplot2_args_multi- |
-
17 | -- |
- #'- |
-
18 | -- |
- #' @inherit shared_params return- |
-
19 | -- |
- #'- |
-
20 | -- |
- #' @examples- |
-
21 | -- |
- #' library(teal.widgets)- |
-
22 | -- |
- #'- |
-
23 | -- |
- #' # module specification used in apps below- |
-
24 | -- |
- #' tm_missing_data_module <- tm_missing_data(- |
-
25 | -- |
- #' ggplot2_args = list(- |
-
26 | -- |
- #' "Combinations Hist" = ggplot2_args(- |
-
27 | -- |
- #' labs = list(subtitle = "Plot produced by Missing Data Module", caption = NULL)- |
-
28 | -- |
- #' ),- |
-
29 | -- |
- #' "Combinations Main" = ggplot2_args(labs = list(title = NULL))- |
-
30 | -- |
- #' )- |
-
31 | -- |
- #' )- |
-
32 | -- |
- #'- |
-
33 | -- |
- #' # general example data- |
-
34 | -- |
- #' data <- teal_data()- |
-
35 | -- |
- #' data <- within(data, {- |
-
36 | -- |
- #' require(nestcolor)- |
-
37 | -- |
- #'- |
-
38 | -- |
- #' add_nas <- function(x) {- |
-
39 | -- |
- #' x[sample(seq_along(x), floor(length(x) * runif(1, .05, .17)))] <- NA- |
-
40 | -- |
- #' x- |
-
41 | -- |
- #' }- |
-
42 | -- |
- #'- |
-
43 | -- |
- #' iris <- iris- |
-
44 | -- |
- #' mtcars <- mtcars- |
-
45 | -- |
- #'- |
-
46 | -- |
- #' iris[] <- lapply(iris, add_nas)- |
-
47 | -- |
- #' mtcars[] <- lapply(mtcars, add_nas)- |
-
48 | -- |
- #' mtcars[["cyl"]] <- as.factor(mtcars[["cyl"]])- |
-
49 | -- |
- #' mtcars[["gear"]] <- as.factor(mtcars[["gear"]])- |
-
50 | -- |
- #' })- |
-
51 | -- |
- #' datanames(data) <- c("iris", "mtcars")- |
-
52 | -- |
- #'- |
-
53 | -- |
- #' app <- init(- |
-
54 | -- |
- #' data = data,- |
-
55 | -- |
- #' modules = modules(tm_missing_data_module)- |
-
56 | -- |
- #' )- |
-
57 | -- |
- #' if (interactive()) {- |
-
58 | -- |
- #' shinyApp(app$ui, app$server)- |
-
59 | -- |
- #' }- |
-
60 | -- |
- #'- |
-
61 | -- |
- #' # CDISC example data- |
-
62 | -- |
- #' data <- teal_data()- |
-
63 | -- |
- #' data <- within(data, {- |
-
64 | -- |
- #' require(nestcolor)- |
-
65 | -- |
- #' ADSL <- rADSL- |
-
66 | -- |
- #' ADRS <- rADRS- |
-
67 | -- |
- #' })- |
-
68 | -- |
- #' datanames(data) <- c("ADSL", "ADRS")- |
-
69 | -- |
- #' join_keys(data) <- default_cdisc_join_keys[datanames(data)]- |
-
70 | -- |
- #'- |
-
71 | -- |
- #' app <- init(- |
-
72 | -- |
- #' data = data,- |
-
73 | -- |
- #' modules = modules(tm_missing_data_module)- |
-
74 | -- |
- #' )- |
-
75 | -- |
- #' if (interactive()) {- |
-
76 | -- |
- #' shinyApp(app$ui, app$server)- |
-
77 | -- |
- #' }- |
-
78 | -- |
- #'- |
-
79 | -- |
- #' @export- |
-
80 | -- |
- #'- |
-
81 | -- |
- tm_missing_data <- function(label = "Missing data",- |
-
82 | -- |
- plot_height = c(600, 400, 5000),- |
-
83 | -- |
- plot_width = NULL,- |
-
84 | -- |
- parent_dataname = "ADSL",- |
-
85 | -- |
- ggtheme = c("classic", "gray", "bw", "linedraw", "light", "dark", "minimal", "void"),- |
-
86 | -- |
- ggplot2_args = list(- |
-
87 | -- |
- "Combinations Hist" = teal.widgets::ggplot2_args(labs = list(caption = NULL)),- |
-
88 | -- |
- "Combinations Main" = teal.widgets::ggplot2_args(labs = list(title = NULL))- |
-
89 | -- |
- ),- |
-
90 | -- |
- pre_output = NULL,- |
-
91 | -- |
- post_output = NULL) {- |
-
92 | -! | -
- logger::log_info("Initializing tm_missing_data")- |
-
93 | -- | - - | -
94 | -- |
- # Requires Suggested packages- |
-
95 | -! | -
- if (!requireNamespace("gridExtra", quietly = TRUE)) {- |
-
96 | -! | -
- stop("Cannot load gridExtra - please install the package or restart your session.")- |
-
97 | -- |
- }- |
-
98 | -! | -
- if (!requireNamespace("rlang", quietly = TRUE)) {- |
-
99 | -! | -
- stop("Cannot load rlang - please install the package or restart your session.")- |
-
100 | -- |
- }- |
-
101 | -- | - - | -
102 | -- |
- # Normalize the parameters- |
-
103 | -! | -
- if (inherits(ggplot2_args, "ggplot2_args")) ggplot2_args <- list(default = ggplot2_args)- |
-
104 | -- | - - | -
105 | -- |
- # Start of assertions- |
-
106 | -! | -
- checkmate::assert_string(label)- |
-
107 | -- | - - | -
108 | -! | -
- checkmate::assert_numeric(plot_height, len = 3, any.missing = FALSE, finite = TRUE)- |
-
109 | -! | -
- checkmate::assert_numeric(plot_height[1], lower = plot_height[2], upper = plot_height[3], .var.name = "plot_height")- |
-
110 | -! | -
- checkmate::assert_numeric(plot_width, len = 3, any.missing = FALSE, null.ok = TRUE, finite = TRUE)- |
-
111 | -! | -
- checkmate::assert_numeric(- |
-
112 | -! | -
- plot_width[1],- |
-
113 | -! | -
- lower = plot_width[2], upper = plot_width[3], null.ok = TRUE, .var.name = "plot_width"- |
-
114 | -- |
- )- |
-
115 | -- | - - | -
116 | -! | -
- checkmate::assert_character(parent_dataname, min.len = 0, max.len = 1)- |
-
117 | -! | -
- ggtheme <- match.arg(ggtheme)- |
-
118 | -- | - - | -
119 | -! | -
- plot_choices <- c("Summary Obs", "Summary Patients", "Combinations Main", "Combinations Hist", "By Subject")- |
-
120 | -! | -
- checkmate::assert_list(ggplot2_args, types = "ggplot2_args")- |
-
121 | -! | -
- checkmate::assert_subset(names(ggplot2_args), c("default", plot_choices))- |
-
122 | -- | - - | -
123 | -! | -
- checkmate::assert_multi_class(pre_output, c("shiny.tag", "shiny.tag.list", "html"), null.ok = TRUE)- |
-
124 | -! | -
- checkmate::assert_multi_class(post_output, c("shiny.tag", "shiny.tag.list", "html"), null.ok = TRUE)- |
-
125 | -- |
- # End of assertions- |
-
126 | -- | - - | -
127 | -! | -
- module(- |
-
128 | -! | -
- label,- |
-
129 | -! | -
- server = srv_page_missing_data,- |
-
130 | -! | -
- server_args = list(- |
-
131 | -! | -
- parent_dataname = parent_dataname, plot_height = plot_height,- |
-
132 | -! | -
- plot_width = plot_width, ggplot2_args = ggplot2_args, ggtheme = ggtheme- |
-
133 | -- |
- ),- |
-
134 | -! | -
- ui = ui_page_missing_data,- |
-
135 | -! | -
- datanames = "all",- |
-
136 | -! | -
- ui_args = list(pre_output = pre_output, post_output = post_output)- |
-
137 | -- |
- )- |
-
138 | -- |
- }- |
-
139 | -- | - - | -
140 | -- |
- # UI function for the missing data module (all datasets)- |
-
141 | -- |
- ui_page_missing_data <- function(id, pre_output = NULL, post_output = NULL) {- |
-
142 | -! | -
- ns <- NS(id)- |
-
143 | -! | -
- shiny::tagList(- |
-
144 | -! | -
- include_css_files("custom"),- |
-
145 | -! | -
- teal.widgets::standard_layout(- |
-
146 | -! | -
- output = teal.widgets::white_small_well(- |
-
147 | -! | -
- div(- |
-
148 | -! | -
- class = "flex",- |
-
149 | -! | -
- column(- |
-
150 | -! | -
- width = 12,- |
-
151 | -! | -
- uiOutput(ns("dataset_tabs"))- |
-
152 | -- |
- )- |
-
153 | -- |
- )- |
-
154 | -- |
- ),- |
-
155 | -! | -
- encoding = div(- |
-
156 | -! | -
- uiOutput(ns("dataset_encodings"))- |
-
157 | -- |
- ),- |
-
158 | -! | -
- uiOutput(ns("dataset_reporter")),- |
-
159 | -! | -
- pre_output = pre_output,- |
-
160 | -! | -
- post_output = post_output- |
-
161 | -- |
- )- |
-
162 | -- |
- )- |
-
163 | -- |
- }- |
-
164 | -- | - - | -
165 | -- |
- # Server function for the missing data module (all datasets)- |
-
166 | -- |
- srv_page_missing_data <- function(id, data, reporter, filter_panel_api, parent_dataname,- |
-
167 | -- |
- plot_height, plot_width, ggplot2_args, ggtheme) {- |
-
168 | -! | -
- moduleServer(id, function(input, output, session) {- |
-
169 | -! | -
- datanames <- isolate(teal.data::datanames(data()))- |
-
170 | -! | -
- datanames <- Filter(function(name) {- |
-
171 | -! | -
- is.data.frame(isolate(data())[[name]])- |
-
172 | -! | -
- }, datanames)- |
-
173 | -! | -
- if_subject_plot <- length(parent_dataname) > 0 && parent_dataname %in% datanames- |
-
174 | -! | -
- ns <- session$ns- |
-
175 | -- | - - | -
176 | -! | -
- output$dataset_tabs <- renderUI({- |
-
177 | -! | -
- do.call(- |
-
178 | -! | -
- tabsetPanel,- |
-
179 | -! | -
- c(- |
-
180 | -! | -
- id = ns("dataname_tab"),- |
-
181 | -! | -
- lapply(- |
-
182 | -! | -
- datanames,- |
-
183 | -! | -
- function(x) {- |
-
184 | -! | -
- tabPanel(- |
-
185 | -! | -
- title = x,- |
-
186 | -! | -
- column(- |
-
187 | -! | -
- width = 12,- |
-
188 | -! | -
- div(- |
-
189 | -! | -
- class = "mt-4",- |
-
190 | -! | -
- ui_missing_data(id = ns(x), by_subject_plot = if_subject_plot)- |
-
191 | -- |
- )- |
-
192 | -- |
- )- |
-
193 | -- |
- )- |
-
194 | -- |
- }- |
-
195 | -- |
- )- |
-
196 | -- |
- )- |
-
197 | -- |
- )- |
-
198 | -- |
- })- |
-
199 | -- | - - | -
200 | -! | -
- output$dataset_encodings <- renderUI({- |
-
201 | -! | -
- tagList(- |
-
202 | -! | -
- lapply(- |
-
203 | -! | -
- datanames,- |
-
204 | -! | -
- function(x) {- |
-
205 | -! | -
- conditionalPanel(- |
-
206 | -! | -
- is_tab_active_js(ns("dataname_tab"), x),- |
-
207 | -! | -
- encoding_missing_data(- |
-
208 | -! | -
- id = ns(x),- |
-
209 | -! | -
- summary_per_patient = if_subject_plot,- |
-
210 | -! | -
- ggtheme = ggtheme,- |
-
211 | -! | -
- datanames = datanames- |
-
212 | -- |
- )- |
-
213 | -- |
- )- |
-
214 | -- |
- }- |
-
215 | -- |
- )- |
-
216 | -- |
- )- |
-
217 | -- |
- })- |
-
218 | -- | - - | -
219 | -! | -
- output$dataset_reporter <- renderUI({- |
-
220 | -! | -
- lapply(datanames, function(x) {- |
-
221 | -! | -
- dataname_ns <- NS(ns(x))- |
-
222 | -- | - - | -
223 | -! | -
- conditionalPanel(- |
-
224 | -! | -
- is_tab_active_js(ns("dataname_tab"), x),- |
-
225 | -! | -
- tagList(- |
-
226 | -! | -
- teal.widgets::verbatim_popup_ui(dataname_ns("warning"), "Show Warnings"),- |
-
227 | -! | -
- teal.widgets::verbatim_popup_ui(dataname_ns("rcode"), "Show R code")- |
-
228 | -- |
- )- |
-
229 | -- |
- )- |
-
230 | -- |
- })- |
-
231 | -- |
- })- |
-
232 | -- | - - | -
233 | -! | -
- lapply(- |
-
234 | -! | -
- datanames,- |
-
235 | -! | -
- function(x) {- |
-
236 | -! | -
- srv_missing_data(- |
-
237 | -! | -
- id = x,- |
-
238 | -! | -
- data = data,- |
-
239 | -! | -
- reporter = reporter,- |
-
240 | -! | -
- filter_panel_api = filter_panel_api,- |
-
241 | -! | -
- dataname = x,- |
-
242 | -! | -
- parent_dataname = parent_dataname,- |
-
243 | -! | -
- plot_height = plot_height,- |
-
244 | -! | -
- plot_width = plot_width,- |
-
245 | -! | -
- ggplot2_args = ggplot2_args- |
-
246 | -- |
- )- |
-
247 | -- |
- }- |
-
248 | -- |
- )- |
-
249 | -- |
- })- |
-
250 | -- |
- }- |
-
251 | -- | - - | -
252 | -- |
- # UI function for the missing data module (single dataset)- |
-
253 | -- |
- ui_missing_data <- function(id, by_subject_plot = FALSE) {- |
-
254 | -! | -
- ns <- NS(id)- |
-
255 | -- | - - | -
256 | -! | -
- tab_list <- list(- |
-
257 | -! | -
- tabPanel(- |
-
258 | -! | -
- "Summary",- |
-
259 | -! | -
- teal.widgets::plot_with_settings_ui(id = ns("summary_plot")),- |
-
260 | -! | -
- helpText(- |
-
261 | -! | -
- p(paste(- |
-
262 | -! | -
- 'The "Summary" graph shows the number of missing values per variable (both absolute and percentage),',- |
-
263 | -! | -
- "sorted by magnitude."- |
-
264 | -- |
- )),- |
-
265 | -! | -
- p(- |
-
266 | -! | -
- 'The "summary per patients" graph is showing how many subjects have at least one missing observation',- |
-
267 | -! | -
- "for each variable. It will be most useful for panel datasets."- |
-
268 | -- |
- )- |
-
269 | -- |
- )- |
-
270 | -- |
- ),- |
-
271 | -! | -
- tabPanel(- |
-
272 | -! | -
- "Combinations",- |
-
273 | -! | -
- teal.widgets::plot_with_settings_ui(id = ns("combination_plot")),- |
-
274 | -! | -
- helpText(- |
-
275 | -! | -
- p(paste(- |
-
276 | -! | -
- 'The "Combinations" graph is used to explore the relationship between the missing data within',- |
-
277 | -! | -
- "different columns of the dataset.",- |
-
278 | -! | -
- "It shows the different patterns of missingness in the rows of the data.",- |
-
279 | -! | -
- 'For example, suppose that 70 rows of the data have exactly columns "A" and "B" missing.',- |
-
280 | -! | -
- "In this case there would be a bar of height 70 in the top graph and",- |
-
281 | -! | -
- 'the column below this in the second graph would have rows "A" and "B" cells shaded red.'- |
-
282 | -- |
- )),- |
-
283 | -! | -
- p(paste(- |
-
284 | -! | -
- "Due to the large number of missing data patterns possible, only those with a large set of observations",- |
-
285 | -! | -
- 'are shown in the graph and the "Combination cut-off" slider can be used to adjust the number shown.'- |
-
286 | -- |
- ))- |
-
287 | -- |
- )- |
-
288 | -- |
- ),- |
-
289 | -! | -
- tabPanel(- |
-
290 | -! | -
- "By Variable Levels",- |
-
291 | -! | -
- teal.widgets::get_dt_rows(ns("levels_table"), ns("levels_table_rows")),- |
-
292 | -! | -
- DT::dataTableOutput(ns("levels_table"))- |
-
293 | -- |
- )- |
-
294 | -- |
- )- |
-
295 | -! | -
- if (isTRUE(by_subject_plot)) {- |
-
296 | -! | -
- tab_list <- append(- |
-
297 | -! | -
- tab_list,- |
-
298 | -! | -
- list(tabPanel(- |
-
299 | -! | -
- "Grouped by Subject",- |
-
300 | -! | -
- teal.widgets::plot_with_settings_ui(id = ns("by_subject_plot")),- |
-
301 | -! | -
- helpText(- |
-
302 | -! | -
- p(paste(- |
-
303 | -! | -
- "This graph shows the missingness with respect to subjects rather than individual rows of the",- |
-
304 | -! | -
- "dataset. Each row represents one dataset variable and each column a single subject. Only subjects",- |
-
305 | -! | -
- "with at least one record in this dataset are shown. For a given subject, if they have any missing",- |
-
306 | -! | -
- "values of a specific variable then the appropriate cell in the graph is marked as missing."- |
-
307 | -- |
- ))- |
-
308 | -- |
- )- |
-
309 | -- |
- ))- |
-
310 | -- |
- )- |
-
311 | -- |
- }- |
-
312 | -- | - - | -
313 | -! | -
- do.call(- |
-
314 | -! | -
- tabsetPanel,- |
-
315 | -! | -
- c(- |
-
316 | -! | -
- id = ns("summary_type"),- |
-
317 | -! | -
- tab_list- |
-
318 | -- |
- )- |
-
319 | -- |
- )- |
-
320 | -- |
- }- |
-
321 | -- | - - | -
322 | -- |
- # UI encoding for the missing data module (all datasets)- |
-
323 | -- |
- encoding_missing_data <- function(id, summary_per_patient = FALSE, ggtheme, datanames) {- |
-
324 | -! | -
- ns <- NS(id)- |
-
325 | -- | - - | -
326 | -! | -
- tagList(- |
-
327 | -- |
- ### Reporter- |
-
328 | -! | -
- teal.reporter::simple_reporter_ui(ns("simple_reporter")),- |
-
329 | -- |
- ###- |
-
330 | -! | -
- tags$label("Encodings", class = "text-primary"),- |
-
331 | -! | -
- helpText(- |
-
332 | -! | -
- paste0("Dataset", `if`(length(datanames) > 1, "s", ""), ":"),- |
-
333 | -! | -
- tags$code(paste(datanames, collapse = ", "))- |
-
334 | -- |
- ),- |
-
335 | -! | -
- uiOutput(ns("variables")),- |
-
336 | -! | -
- actionButton(- |
-
337 | -! | -
- ns("filter_na"),- |
-
338 | -! | -
- span("Select only vars with missings", class = "whitespace-normal"),- |
-
339 | -! | -
- width = "100%",- |
-
340 | -! | -
- class = "mb-4"- |
-
341 | -- |
- ),- |
-
342 | -! | -
- conditionalPanel(- |
-
343 | -! | -
- is_tab_active_js(ns("summary_type"), "Summary"),- |
-
344 | -! | -
- checkboxInput(- |
-
345 | -! | -
- ns("any_na"),- |
-
346 | -! | -
- div(- |
-
347 | -! | -
- class = "teal-tooltip",- |
-
348 | -! | -
- tagList(- |
-
349 | -! | -
- "Add **anyna** variable",- |
-
350 | -! | -
- icon("circle-info"),- |
-
351 | -! | -
- span(- |
-
352 | -! | -
- class = "tooltiptext",- |
-
353 | -! | -
- "Describes the number of observations with at least one missing value in any variable."- |
-
354 | -- |
- )- |
-
355 | -- |
- )- |
-
356 | -- |
- ),- |
-
357 | -! | -
- value = FALSE- |
-
358 | -- |
- ),- |
-
359 | -! | -
- if (summary_per_patient) {- |
-
360 | -! | -
- checkboxInput(- |
-
361 | -! | -
- ns("if_patients_plot"),- |
-
362 | -! | -
- div(- |
-
363 | -! | -
- class = "teal-tooltip",- |
-
364 | -! | -
- tagList(- |
-
365 | -! | -
- "Add summary per patients",- |
-
366 | -! | -
- icon("circle-info"),- |
-
367 | -! | -
- span(- |
-
368 | -! | -
- class = "tooltiptext",- |
-
369 | -! | -
- paste(- |
-
370 | -! | -
- "Displays the number of missing values per observation,",- |
-
371 | -! | -
- "where the x-axis is sorted by observation appearance in the table."- |
-
372 | -- |
- )- |
-
373 | -- |
- )- |
-
374 | -- |
- )- |
-
375 | -- |
- ),- |
-
376 | -! | -
- value = FALSE- |
-
377 | -- |
- )- |
-
378 | -- |
- }- |
-
379 | -- |
- ),- |
-
380 | -! | -
- conditionalPanel(- |
-
381 | -! | -
- is_tab_active_js(ns("summary_type"), "Combinations"),- |
-
382 | -! | -
- uiOutput(ns("cutoff"))- |
-
383 | -- |
- ),- |
-
384 | -! | -
- conditionalPanel(- |
-
385 | -! | -
- is_tab_active_js(ns("summary_type"), "By Variable Levels"),- |
-
386 | -! | -
- tagList(- |
-
387 | -! | -
- uiOutput(ns("group_by_var_ui")),- |
-
388 | -! | -
- uiOutput(ns("group_by_vals_ui")),- |
-
389 | -! | -
- radioButtons(- |
-
390 | -! | -
- ns("count_type"),- |
-
391 | -! | -
- label = "Display missing as",- |
-
392 | -! | -
- choices = c("counts", "proportions"),- |
-
393 | -! | -
- selected = "counts",- |
-
394 | -! | -
- inline = TRUE- |
-
395 | -- |
- )- |
-
396 | -- |
- )- |
-
397 | -- |
- ),- |
-
398 | -! | -
- teal.widgets::panel_item(- |
-
399 | -! | -
- title = "Plot settings",- |
-
400 | -! | -
- selectInput(- |
-
401 | -! | -
- inputId = ns("ggtheme"),- |
-
402 | -! | -
- label = "Theme (by ggplot):",- |
-
403 | -! | -
- choices = ggplot_themes,- |
-
404 | -! | -
- selected = ggtheme,- |
-
405 | -! | -
- multiple = FALSE- |
-
406 | -- |
- )- |
-
407 | -- |
- )- |
-
408 | -- |
- )- |
-
409 | -- |
- }- |
-
410 | -- | - - | -
411 | -- |
- # Server function for the missing data (single dataset)- |
-
412 | -- |
- srv_missing_data <- function(id, data, reporter, filter_panel_api, dataname, parent_dataname,- |
-
413 | -- |
- plot_height, plot_width, ggplot2_args) {- |
-
414 | -! | -
- with_reporter <- !missing(reporter) && inherits(reporter, "Reporter")- |
-
415 | -! | -
- with_filter <- !missing(filter_panel_api) && inherits(filter_panel_api, "FilterPanelAPI")- |
-
416 | -! | -
- checkmate::assert_class(data, "reactive")- |
-
417 | -! | -
- checkmate::assert_class(isolate(data()), "teal_data")- |
-
418 | -! | -
- moduleServer(id, function(input, output, session) {- |
-
419 | -! | -
- prev_group_by_var <- reactiveVal("")- |
-
420 | -! | -
- data_r <- reactive(data()[[dataname]])- |
-
421 | -! | -
- data_keys <- reactive(unlist(teal.data::join_keys(data())[[dataname]]))- |
-
422 | -- | - - | -
423 | -! | -
- iv_r <- reactive({- |
-
424 | -! | -
- iv <- shinyvalidate::InputValidator$new()- |
-
425 | -! | -
- iv$add_rule(- |
-
426 | -! | -
- "variables_select",- |
-
427 | -! | -
- shinyvalidate::sv_required("At least one reference variable needs to be selected.")- |
-
428 | -- |
- )- |
-
429 | -! | -
- iv$add_rule(- |
-
430 | -! | -
- "variables_select",- |
-
431 | -! | -
- ~ if (length(setdiff((.), data_keys())) < 1) "Please also select non-key columns."- |
-
432 | -- |
- )- |
-
433 | -! | -
- iv_summary_table <- shinyvalidate::InputValidator$new()- |
-
434 | -! | -
- iv_summary_table$condition(~ isTRUE(input$summary_type == "By Variable Levels"))- |
-
435 | -! | -
- iv_summary_table$add_rule("count_type", shinyvalidate::sv_required("Please select type of counts"))- |
-
436 | -! | -
- iv_summary_table$add_rule(- |
-
437 | -! | -
- "group_by_vals",- |
-
438 | -! | -
- shinyvalidate::sv_required("Please select both group-by variable and values")- |
-
439 | -- |
- )- |
-
440 | -! | -
- iv_summary_table$add_rule(- |
-
441 | -! | -
- "group_by_var",- |
-
442 | -! | -
- ~ if (length(.) > 0 && length(input$variables_select) == 1 && (.) == input$variables_select) {- |
-
443 | -! | -
- "If only one reference variable is selected it must not be the grouping variable."- |
-
444 | -- |
- }- |
-
445 | -- |
- )- |
-
446 | -! | -
- iv_summary_table$add_rule(- |
-
447 | -! | -
- "variables_select",- |
-
448 | -! | -
- ~ if (length(input$group_by_var) > 0 && length(.) == 1 && (.) == input$group_by_var) {- |
-
449 | -! | -
- "If only one reference variable is selected it must not be the grouping variable."- |
-
450 | -- |
- }- |
-
451 | -- |
- )- |
-
452 | -! | -
- iv$add_validator(iv_summary_table)- |
-
453 | -! | -
- iv$enable()- |
-
454 | -! | -
- iv- |
-
455 | -- |
- })- |
-
456 | -- | - - | -
457 | -- | - - | -
458 | -! | -
- data_parent_keys <- reactive({- |
-
459 | -! | -
- if (length(parent_dataname) > 0 && parent_dataname %in% names(data)) {- |
-
460 | -! | -
- keys <- teal.data::join_keys(data)[[dataname]]- |
-
461 | -! | -
- if (parent_dataname %in% names(keys)) {- |
-
462 | -! | -
- keys[[parent_dataname]]- |
-
463 | -- |
- } else {- |
-
464 | -! | -
- keys[[dataname]]- |
-
465 | -- |
- }- |
-
466 | -- |
- } else {- |
-
467 | -! | -
- NULL- |
-
468 | -- |
- }- |
-
469 | -- |
- })- |
-
470 | -- | - - | -
471 | -! | -
- common_code_q <- reactive({- |
-
472 | -! | -
- teal::validate_inputs(iv_r())- |
-
473 | -- | - - | -
474 | -! | -
- group_var <- input$group_by_var- |
-
475 | -! | -
- anl <- data_r()- |
-
476 | -- | - - | -
477 | -! | -
- qenv <- if (!is.null(selected_vars()) && length(selected_vars()) != ncol(anl)) {- |
-
478 | -! | -
- teal.code::eval_code(- |
-
479 | -! | -
- data(),- |
-
480 | -! | -
- substitute(- |
-
481 | -! | -
- expr = ANL <- anl_name[, selected_vars, drop = FALSE],- |
-
482 | -! | -
- env = list(anl_name = as.name(dataname), selected_vars = selected_vars())- |
-
483 | -- |
- )- |
-
484 | -- |
- )- |
-
485 | -- |
- } else {- |
-
486 | -! | -
- teal.code::eval_code(- |
-
487 | -! | -
- data(),- |
-
488 | -! | -
- substitute(expr = ANL <- anl_name, env = list(anl_name = as.name(dataname)))- |
-
489 | -- |
- )- |
-
490 | -- |
- }- |
-
491 | -- | - - | -
492 | -! | -
- if (input$summary_type == "By Variable Levels" && !is.null(group_var) && !(group_var %in% selected_vars())) {- |
-
493 | -! | -
- qenv <- teal.code::eval_code(- |
-
494 | -! | -
- qenv,- |
-
495 | -! | -
- substitute(- |
-
496 | -! | -
- expr = ANL[[group_var]] <- anl_name[[group_var]],- |
-
497 | -! | -
- env = list(group_var = group_var, anl_name = as.name(dataname))- |
-
498 | -- |
- )- |
-
499 | -- |
- )- |
-
500 | -- |
- }- |
-
501 | -- | - - | -
502 | -! | -
- new_col_name <- "**anyna**"- |
-
503 | -- | - - | -
504 | -! | -
- qenv <- teal.code::eval_code(- |
-
505 | -! | -
- qenv,- |
-
506 | -! | -
- substitute(- |
-
507 | -! | -
- expr =- |
-
508 | -! | -
- create_cols_labels <- function(cols, just_label = FALSE) {- |
-
509 | -! | -
- column_labels <- column_labels_value- |
-
510 | -! | -
- column_labels[is.na(column_labels) | length(column_labels) == 0] <- ""- |
-
511 | -! | -
- if (just_label) {- |
-
512 | -! | -
- labels <- column_labels[cols]- |
-
513 | -- |
- } else {- |
-
514 | -! | -
- labels <- ifelse(cols == new_col_name | cols == "", cols, paste0(column_labels[cols], " [", cols, "]"))- |
-
515 | -- |
- }- |
-
516 | -! | -
- labels- |
-
517 | -- |
- },- |
-
518 | -! | -
- env = list(- |
-
519 | -! | -
- new_col_name = new_col_name,- |
-
520 | -! | -
- column_labels_value = c(teal.data::col_labels(data_r())[selected_vars()],- |
-
521 | -! | -
- new_col_name = new_col_name- |
-
522 | -- |
- )- |
-
523 | -- |
- )- |
-
524 | -- |
- )- |
-
525 | -- |
- )- |
-
526 | -! | -
- qenv- |
-
527 | -- |
- })- |
-
528 | -- | - - | -
529 | -! | -
- selected_vars <- reactive({- |
-
530 | -! | -
- req(input$variables_select)- |
-
531 | -! | -
- keys <- data_keys()- |
-
532 | -! | -
- vars <- unique(c(keys, input$variables_select))- |
-
533 | -! | -
- vars- |
-
534 | -- |
- })- |
-
535 | -- | - - | -
536 | -! | -
- vars_summary <- reactive({- |
-
537 | -! | -
- na_count <- data_r() %>%- |
-
538 | -! | -
- sapply(function(x) mean(is.na(x)), USE.NAMES = TRUE) %>%- |
-
539 | -! | -
- sort(decreasing = TRUE)- |
-
540 | -- | - - | -
541 | -! | -
- tibble::tibble(- |
-
542 | -! | -
- key = names(na_count),- |
-
543 | -! | -
- value = unname(na_count),- |
-
544 | -! | -
- label = cut(na_count, breaks = seq(from = 0, to = 1, by = 0.1), include.lowest = TRUE)- |
-
545 | -- |
- )- |
-
546 | -- |
- })- |
-
547 | -- | - - | -
548 | -! | -
- output$variables <- renderUI({- |
-
549 | -! | -
- choices <- split(x = vars_summary()$key, f = vars_summary()$label, drop = TRUE) %>% rev()- |
-
550 | -! | -
- selected <- choices <- unname(unlist(choices))- |
-
551 | -- | - - | -
552 | -! | -
- teal.widgets::optionalSelectInput(- |
-
553 | -! | -
- session$ns("variables_select"),- |
-
554 | -! | -
- label = "Select variables",- |
-
555 | -! | -
- label_help = HTML(paste0("Dataset: ", tags$code(dataname))),- |
-
556 | -! | -
- choices = teal.transform::variable_choices(data_r(), choices),- |
-
557 | -! | -
- selected = selected,- |
-
558 | -! | -
- multiple = TRUE- |
-
559 | -- |
- )- |
-
560 | -- |
- })- |
-
561 | -- | - - | -
562 | -! | -
- observeEvent(input$filter_na, {- |
-
563 | -! | -
- choices <- vars_summary() %>%- |
-
564 | -! | -
- dplyr::select(!!as.name("key")) %>%- |
-
565 | -! | -
- getElement(name = 1)- |
-
566 | -- | - - | -
567 | -! | -
- selected <- vars_summary() %>%- |
-
568 | -! | -
- dplyr::filter(!!as.name("value") > 0) %>%- |
-
569 | -! | -
- dplyr::select(!!as.name("key")) %>%- |
-
570 | -! | -
- getElement(name = 1)- |
-
571 | -- | - - | -
572 | -! | -
- teal.widgets::updateOptionalSelectInput(- |
-
573 | -! | -
- session = session,- |
-
574 | -! | -
- inputId = "variables_select",- |
-
575 | -! | -
- choices = teal.transform::variable_choices(data_r()),- |
-
576 | -! | -
- selected = selected- |
-
577 | -- |
- )- |
-
578 | -- |
- })- |
-
579 | -- | - - | -
580 | -! | -
- output$group_by_var_ui <- renderUI({- |
-
581 | -! | -
- all_choices <- teal.transform::variable_choices(data_r())- |
-
582 | -! | -
- cat_choices <- all_choices[!sapply(data_r(), function(x) is.numeric(x) || inherits(x, "POSIXct"))]- |
-
583 | -! | -
- validate(- |
-
584 | -! | -
- need(cat_choices, "Dataset does not have any non-numeric or non-datetime variables to use to group data with")- |
-
585 | -- |
- )- |
-
586 | -! | -
- teal.widgets::optionalSelectInput(- |
-
587 | -! | -
- session$ns("group_by_var"),- |
-
588 | -! | -
- label = "Group by variable",- |
-
589 | -! | -
- choices = cat_choices,- |
-
590 | -! | -
- selected = `if`(- |
-
591 | -! | -
- is.null(isolate(input$group_by_var)),- |
-
592 | -! | -
- cat_choices[1],- |
-
593 | -! | -
- isolate(input$group_by_var)- |
-
594 | -- |
- ),- |
-
595 | -! | -
- multiple = FALSE,- |
-
596 | -! | -
- label_help = paste0("Dataset: ", dataname)- |
-
597 | -- |
- )- |
-
598 | -- |
- })- |
-
599 | -- | - - | -
600 | -! | -
- output$group_by_vals_ui <- renderUI({- |
-
601 | -! | -
- req(input$group_by_var)- |
-
602 | -- | - - | -
603 | -! | -
- choices <- teal.transform::value_choices(data_r(), input$group_by_var, input$group_by_var)- |
-
604 | -! | -
- prev_choices <- isolate(input$group_by_vals)- |
-
605 | -- | - - | -
606 | -- |
- # determine selected value based on filtered data- |
-
607 | -- |
- # display those previously selected values that are still available- |
-
608 | -! | -
- selected <- if (!is.null(prev_choices) && any(prev_choices %in% choices)) {- |
-
609 | -! | -
- prev_choices[match(choices[choices %in% prev_choices], prev_choices)]- |
-
610 | -! | -
- } else if (- |
-
611 | -! | -
- !is.null(prev_choices) &&- |
-
612 | -! | -
- !any(prev_choices %in% choices) &&- |
-
613 | -! | -
- isolate(prev_group_by_var()) == input$group_by_var- |
-
614 | -- |
- ) {- |
-
615 | -- |
- # if not any previously selected value is available and the grouping variable is the same,- |
-
616 | -- |
- # then display NULL- |
-
617 | -! | -
- NULL- |
-
618 | -- |
- } else {- |
-
619 | -- |
- # if new grouping variable (i.e. not any previously selected value is available),- |
-
620 | -- |
- # then display all choices- |
-
621 | -! | -
- choices- |
-
622 | -- |
- }- |
-
623 | -- | - - | -
624 | -! | -
- prev_group_by_var(input$group_by_var) # set current group_by_var- |
-
625 | -! | -
- validate(need(length(choices) < 100, "Please select group-by variable with fewer than 100 unique values"))- |
-
626 | -- | - - | -
627 | -! | -
- teal.widgets::optionalSelectInput(- |
-
628 | -! | -
- session$ns("group_by_vals"),- |
-
629 | -! | -
- label = "Filter levels",- |
-
630 | -! | -
- choices = choices,- |
-
631 | -! | -
- selected = selected,- |
-
632 | -! | -
- multiple = TRUE,- |
-
633 | -! | -
- label_help = paste0("Dataset: ", dataname)- |
-
634 | -- |
- )- |
-
635 | -- |
- })- |
-
636 | -- | - - | -
637 | -! | -
- summary_plot_q <- reactive({- |
-
638 | -! | -
- req(input$summary_type == "Summary") # needed to trigger show r code update on tab change- |
-
639 | -! | -
- teal::validate_has_data(data_r(), 1)- |
-
640 | -- | - - | -
641 | -! | -
- qenv <- common_code_q()- |
-
642 | -- | - - | -
643 | -! | -
- if (input$any_na) {- |
-
644 | -! | -
- new_col_name <- "**anyna**"- |
-
645 | -! | -
- qenv <- teal.code::eval_code(- |
-
646 | -! | -
- qenv,- |
-
647 | -! | -
- substitute(- |
-
648 | -! | -
- expr = ANL[[new_col_name]] <- ifelse(rowSums(is.na(ANL)) > 0, NA, FALSE),- |
-
649 | -! | -
- env = list(new_col_name = new_col_name)- |
-
650 | -- |
- )- |
-
651 | -- |
- )- |
-
652 | -- |
- }- |
-
653 | -- | - - | -
654 | -! | -
- qenv <- teal.code::eval_code(- |
-
655 | -! | -
- qenv,- |
-
656 | -! | -
- substitute(- |
-
657 | -! | -
- expr = analysis_vars <- setdiff(colnames(ANL), data_keys),- |
-
658 | -! | -
- env = list(data_keys = data_keys())- |
-
659 | -- |
- )- |
-
660 | -- |
- ) %>%- |
-
661 | -! | -
- teal.code::eval_code(- |
-
662 | -! | -
- substitute(- |
-
663 | -! | -
- expr = summary_plot_obs <- data_frame_call[, analysis_vars] %>%- |
-
664 | -! | -
- dplyr::summarise_all(list(function(x) sum(is.na(x)))) %>%- |
-
665 | -! | -
- tidyr::pivot_longer(dplyr::everything(), names_to = "col", values_to = "n_na") %>%- |
-
666 | -! | -
- dplyr::mutate(n_not_na = nrow(ANL) - n_na) %>%- |
-
667 | -! | -
- tidyr::pivot_longer(-col, names_to = "isna", values_to = "n") %>%- |
-
668 | -! | -
- dplyr::mutate(isna = isna == "n_na", n_pct = n / nrow(ANL) * 100),- |
-
669 | -! | -
- env = list(data_frame_call = if (!inherits(data_r(), "tbl_df")) {- |
-
670 | -! | -
- quote(tibble::as_tibble(ANL))- |
-
671 | -- |
- } else {- |
-
672 | -! | -
- quote(ANL)- |
-
673 | -- |
- })- |
-
674 | -- |
- )- |
-
675 | -- |
- ) %>%- |
-
676 | -- |
- # x axis ordering according to number of missing values and alphabet- |
-
677 | -! | -
- teal.code::eval_code(- |
-
678 | -! | -
- quote(- |
-
679 | -! | -
- expr = x_levels <- dplyr::filter(summary_plot_obs, isna) %>%- |
-
680 | -! | -
- dplyr::arrange(n_pct, dplyr::desc(col)) %>%- |
-
681 | -! | -
- dplyr::pull(col) %>%- |
-
682 | -! | -
- create_cols_labels()- |
-
683 | -- |
- )- |
-
684 | -- |
- )- |
-
685 | -- | - - | -
686 | -- |
- # always set "**anyna**" level as the last one- |
-
687 | -! | -
- if (isolate(input$any_na)) {- |
-
688 | -! | -
- qenv <- teal.code::eval_code(- |
-
689 | -! | -
- qenv,- |
-
690 | -! | -
- quote(x_levels <- c(setdiff(x_levels, "**anyna**"), "**anyna**"))- |
-
691 | -- |
- )- |
-
692 | -- |
- }- |
-
693 | -- | - - | -
694 | -! | -
- dev_ggplot2_args <- teal.widgets::ggplot2_args(- |
-
695 | -! | -
- labs = list(x = "Variable", y = "Missing observations"),- |
-
696 | -! | -
- theme = list(legend.position = "bottom", axis.text.x = quote(element_text(angle = 45, hjust = 1)))- |
-
697 | -- |
- )- |
-
698 | -- | - - | -
699 | -! | -
- all_ggplot2_args <- teal.widgets::resolve_ggplot2_args(- |
-
700 | -! | -
- user_plot = ggplot2_args[["Summary Obs"]],- |
-
701 | -! | -
- user_default = ggplot2_args$default,- |
-
702 | -! | -
- module_plot = dev_ggplot2_args- |
-
703 | -- |
- )- |
-
704 | -- | - - | -
705 | -! | -
- parsed_ggplot2_args <- teal.widgets::parse_ggplot2_args(- |
-
706 | -! | -
- all_ggplot2_args,- |
-
707 | -! | -
- ggtheme = input$ggtheme- |
-
708 | -- |
- )- |
-
709 | -- | - - | -
710 | -! | -
- qenv <- teal.code::eval_code(- |
-
711 | -! | -
- qenv,- |
-
712 | -! | -
- substitute(- |
-
713 | -! | -
- p1 <- summary_plot_obs %>%- |
-
714 | -! | -
- ggplot() +- |
-
715 | -! | -
- aes(- |
-
716 | -! | -
- x = factor(create_cols_labels(col), levels = x_levels),- |
-
717 | -! | -
- y = n_pct,- |
-
718 | -! | -
- fill = isna- |
-
719 | -- |
- ) +- |
-
720 | -! | -
- geom_bar(position = "fill", stat = "identity") +- |
-
721 | -! | -
- scale_fill_manual(- |
-
722 | -! | -
- name = "",- |
-
723 | -! | -
- values = c("grey90", c(getOption("ggplot2.discrete.colour")[2], "#ff2951ff")[1]),- |
-
724 | -! | -
- labels = c("Present", "Missing")- |
-
725 | -- |
- ) +- |
-
726 | -! | -
- scale_y_continuous(labels = scales::percent_format(), breaks = seq(0, 1, by = 0.1), expand = c(0, 0)) +- |
-
727 | -! | -
- geom_text(- |
-
728 | -! | -
- aes(label = ifelse(isna == TRUE, sprintf("%d [%.02f%%]", n, n_pct), ""), y = 1),- |
-
729 | -! | -
- hjust = 1,- |
-
730 | -! | -
- color = "black"- |
-
731 | -- |
- ) +- |
-
732 | -! | -
- labs +- |
-
733 | -! | -
- ggthemes +- |
-
734 | -! | -
- themes +- |
-
735 | -! | -
- coord_flip(),- |
-
736 | -! | -
- env = list(- |
-
737 | -! | -
- labs = parsed_ggplot2_args$labs,- |
-
738 | -! | -
- themes = parsed_ggplot2_args$theme,- |
-
739 | -! | -
- ggthemes = parsed_ggplot2_args$ggtheme- |
-
740 | -- |
- )- |
-
741 | -- |
- )- |
-
742 | -- |
- )- |
-
743 | -- | - - | -
744 | -! | -
- if (isTRUE(input$if_patients_plot)) {- |
-
745 | -! | -
- qenv <- teal.code::eval_code(- |
-
746 | -! | -
- qenv,- |
-
747 | -! | -
- substitute(- |
-
748 | -! | -
- expr = parent_keys <- keys,- |
-
749 | -! | -
- env = list(keys = data_parent_keys())- |
-
750 | -- |
- )- |
-
751 | -- |
- ) %>%- |
-
752 | -! | -
- teal.code::eval_code(quote(ndistinct_subjects <- dplyr::n_distinct(ANL[, parent_keys]))) %>%- |
-
753 | -! | -
- teal.code::eval_code(- |
-
754 | -! | -
- quote(- |
-
755 | -! | -
- summary_plot_patients <- ANL[, c(parent_keys, analysis_vars)] %>%- |
-
756 | -! | -
- dplyr::group_by_at(parent_keys) %>%- |
-
757 | -! | -
- dplyr::summarise_all(anyNA) %>%- |
-
758 | -! | -
- tidyr::pivot_longer(cols = !dplyr::all_of(parent_keys), names_to = "col", values_to = "anyna") %>%- |
-
759 | -! | -
- dplyr::group_by_at(c("col")) %>%- |
-
760 | -! | -
- dplyr::summarise(count_na = sum(anyna)) %>%- |
-
761 | -! | -
- dplyr::mutate(count_not_na = ndistinct_subjects - count_na) %>%- |
-
762 | -! | -
- tidyr::pivot_longer(-c(col), names_to = "isna", values_to = "n") %>%- |
-
763 | -! | -
- dplyr::mutate(isna = isna == "count_na", n_pct = n / ndistinct_subjects * 100) %>%- |
-
764 | -! | -
- dplyr::arrange_at(c("isna", "n"), .funs = dplyr::desc)- |
-
765 | -- |
- )- |
-
766 | -- |
- )- |
-
767 | -- | - - | -
768 | -! | -
- dev_ggplot2_args <- teal.widgets::ggplot2_args(- |
-
769 | -! | -
- labs = list(x = "", y = "Missing patients"),- |
-
770 | -! | -
- theme = list(- |
-
771 | -! | -
- legend.position = "bottom",- |
-
772 | -! | -
- axis.text.x = quote(element_text(angle = 45, hjust = 1)),- |
-
773 | -! | -
- axis.text.y = quote(element_blank())- |
-
774 | -- |
- )- |
-
775 | -- |
- )- |
-
776 | -- | - - | -
777 | -! | -
- all_ggplot2_args <- teal.widgets::resolve_ggplot2_args(- |
-
778 | -! | -
- user_plot = ggplot2_args[["Summary Patients"]],- |
-
779 | -! | -
- user_default = ggplot2_args$default,- |
-
780 | -! | -
- module_plot = dev_ggplot2_args- |
-
781 | -- |
- )- |
-
782 | -- | - - | -
783 | -! | -
- parsed_ggplot2_args <- teal.widgets::parse_ggplot2_args(- |
-
784 | -! | -
- all_ggplot2_args,- |
-
785 | -! | -
- ggtheme = input$ggtheme- |
-
786 | -- |
- )- |
-
787 | -- | - - | -
788 | -! | -
- qenv <- teal.code::eval_code(- |
-
789 | -! | -
- qenv,- |
-
790 | -! | -
- substitute(- |
-
791 | -! | -
- p2 <- summary_plot_patients %>%- |
-
792 | -! | -
- ggplot() +- |
-
793 | -! | -
- aes_(- |
-
794 | -! | -
- x = ~ factor(create_cols_labels(col), levels = x_levels),- |
-
795 | -! | -
- y = ~n_pct,- |
-
796 | -! | -
- fill = ~isna- |
-
797 | -- |
- ) +- |
-
798 | -! | -
- geom_bar(alpha = 1, stat = "identity", position = "fill") +- |
-
799 | -! | -
- scale_y_continuous(labels = scales::percent_format(), breaks = seq(0, 1, by = 0.1), expand = c(0, 0)) +- |
-
800 | -! | -
- scale_fill_manual(- |
-
801 | -! | -
- name = "",- |
-
802 | -! | -
- values = c("grey90", c(getOption("ggplot2.discrete.colour")[2], "#ff2951ff")[1]),- |
-
803 | -! | -
- labels = c("Present", "Missing")- |
-
804 | -- |
- ) +- |
-
805 | -! | -
- geom_text(- |
-
806 | -! | -
- aes(label = ifelse(isna == TRUE, sprintf("%d [%.02f%%]", n, n_pct), ""), y = 1),- |
-
807 | -! | -
- hjust = 1,- |
-
808 | -! | -
- color = "black"- |
-
809 | -- |
- ) +- |
-
810 | -! | -
- labs +- |
-
811 | -! | -
- ggthemes +- |
-
812 | -! | -
- themes +- |
-
813 | -! | -
- coord_flip(),- |
-
814 | -! | -
- env = list(- |
-
815 | -! | -
- labs = parsed_ggplot2_args$labs,- |
-
816 | -! | -
- themes = parsed_ggplot2_args$theme,- |
-
817 | -! | -
- ggthemes = parsed_ggplot2_args$ggtheme- |
-
818 | -- |
- )- |
-
819 | -- |
- )- |
-
820 | -- |
- ) %>%- |
-
821 | -! | -
- teal.code::eval_code(- |
-
822 | -! | -
- quote({- |
-
823 | -! | -
- g1 <- ggplotGrob(p1)- |
-
824 | -! | -
- g2 <- ggplotGrob(p2)- |
-
825 | -! | -
- g <- gridExtra::gtable_cbind(g1, g2, size = "first")- |
-
826 | -! | -
- g$heights <- grid::unit.pmax(g1$heights, g2$heights)- |
-
827 | -! | -
- grid::grid.newpage()- |
-
828 | -- |
- })- |
-
829 | -- |
- )- |
-
830 | -- |
- } else {- |
-
831 | -! | -
- qenv <- teal.code::eval_code(- |
-
832 | -! | -
- qenv,- |
-
833 | -! | -
- quote({- |
-
834 | -! | -
- g <- ggplotGrob(p1)- |
-
835 | -! | -
- grid::grid.newpage()- |
-
836 | -- |
- })- |
-
837 | -- |
- )- |
-
838 | -- |
- }- |
-
839 | -- | - - | -
840 | -! | -
- teal.code::eval_code(- |
-
841 | -! | -
- qenv,- |
-
842 | -! | -
- quote(grid::grid.draw(g))- |
-
843 | -- |
- )- |
-
844 | -- |
- })- |
-
845 | -- | - - | -
846 | -! | -
- summary_plot_r <- reactive(summary_plot_q()[["g"]])- |
-
847 | -- | - - | -
848 | -! | -
- combination_cutoff_q <- reactive({- |
-
849 | -! | -
- req(common_code_q())- |
-
850 | -! | -
- teal.code::eval_code(- |
-
851 | -! | -
- common_code_q(),- |
-
852 | -! | -
- quote(- |
-
853 | -! | -
- combination_cutoff <- ANL %>%- |
-
854 | -! | -
- dplyr::mutate_all(is.na) %>%- |
-
855 | -! | -
- dplyr::group_by_all() %>%- |
-
856 | -! | -
- dplyr::tally() %>%- |
-
857 | -! | -
- dplyr::ungroup()- |
-
858 | -- |
- )- |
-
859 | -- |
- )- |
-
860 | -- |
- })- |
-
861 | -- | - - | -
862 | -! | -
- output$cutoff <- renderUI({- |
-
863 | -! | -
- x <- combination_cutoff_q()[["combination_cutoff"]]$n- |
-
864 | -- | - - | -
865 | -- |
- # select 10-th from the top- |
-
866 | -! | -
- n <- length(x)- |
-
867 | -! | -
- idx <- max(1, n - 10)- |
-
868 | -! | -
- prev_value <- isolate(input$combination_cutoff)- |
-
869 | -! | -
- value <- `if`(- |
-
870 | -! | -
- is.null(prev_value) || prev_value > max(x) || prev_value < min(x),- |
-
871 | -! | -
- sort(x, partial = idx)[idx], prev_value- |
-
872 | -- |
- )- |
-
873 | -- | - - | -
874 | -! | -
- teal.widgets::optionalSliderInputValMinMax(- |
-
875 | -! | -
- session$ns("combination_cutoff"),- |
-
876 | -! | -
- "Combination cut-off",- |
-
877 | -! | -
- c(value, range(x))- |
-
878 | -- |
- )- |
-
879 | -- |
- })- |
-
880 | -- | - - | -
881 | -! | -
- combination_plot_q <- reactive({- |
-
882 | -! | -
- req(input$summary_type == "Combinations", input$combination_cutoff, combination_cutoff_q())- |
-
883 | -! | -
- teal::validate_has_data(data_r(), 1)- |
-
884 | -- | - - | -
885 | -! | -
- qenv <- teal.code::eval_code(- |
-
886 | -! | -
- combination_cutoff_q(),- |
-
887 | -! | -
- substitute(- |
-
888 | -! | -
- expr = data_combination_plot_cutoff <- combination_cutoff %>%- |
-
889 | -! | -
- dplyr::filter(n >= combination_cutoff_value) %>%- |
-
890 | -! | -
- dplyr::mutate(id = rank(-n, ties.method = "first")) %>%- |
-
891 | -! | -
- tidyr::pivot_longer(-c(n, id), names_to = "key", values_to = "value") %>%- |
-
892 | -! | -
- dplyr::arrange(n),- |
-
893 | -! | -
- env = list(combination_cutoff_value = input$combination_cutoff)- |
-
894 | -- |
- )- |
-
895 | -- |
- )- |
-
896 | -- | - - | -
897 | -- |
- # find keys in dataset not selected in the UI and remove them from dataset- |
-
898 | -! | -
- keys_not_selected <- setdiff(data_keys(), input$variables_select)- |
-
899 | -! | -
- if (length(keys_not_selected) > 0) {- |
-
900 | -! | -
- qenv <- teal.code::eval_code(- |
-
901 | -! | -
- qenv,- |
-
902 | -! | -
- substitute(- |
-
903 | -! | -
- expr = data_combination_plot_cutoff <- data_combination_plot_cutoff %>%- |
-
904 | -! | -
- dplyr::filter(!key %in% keys_not_selected),- |
-
905 | -! | -
- env = list(keys_not_selected = keys_not_selected)- |
-
906 | -- |
- )- |
-
907 | -- |
- )- |
-
908 | -- |
- }- |
-
909 | -- | - - | -
910 | -! | -
- qenv <- teal.code::eval_code(- |
-
911 | -! | -
- qenv,- |
-
912 | -! | -
- quote(- |
-
913 | -! | -
- labels <- data_combination_plot_cutoff %>%- |
-
914 | -! | -
- dplyr::filter(key == key[[1]]) %>%- |
-
915 | -! | -
- getElement(name = 1)- |
-
916 | -- |
- )- |
-
917 | -- |
- )- |
-
918 | -- | - - | -
919 | -! | -
- dev_ggplot2_args1 <- teal.widgets::ggplot2_args(- |
-
920 | -! | -
- labs = list(x = "", y = ""),- |
-
921 | -! | -
- theme = list(- |
-
922 | -! | -
- legend.position = "bottom",- |
-
923 | -! | -
- axis.text.x = quote(element_blank())- |
-
924 | -- |
- )- |
-
925 | -- |
- )- |
-
926 | -- | - - | -
927 | -! | -
- all_ggplot2_args1 <- teal.widgets::resolve_ggplot2_args(- |
-
928 | -! | -
- user_plot = ggplot2_args[["Combinations Hist"]],- |
-
929 | -! | -
- user_default = ggplot2_args$default,- |
-
930 | -! | -
- module_plot = dev_ggplot2_args1- |
-
931 | -- |
- )- |
-
932 | -- | - - | -
933 | -! | -
- parsed_ggplot2_args1 <- teal.widgets::parse_ggplot2_args(- |
-
934 | -! | -
- all_ggplot2_args1,- |
-
935 | -! | -
- ggtheme = "void"- |
-
936 | -- |
- )- |
-
937 | -- | - - | -
938 | -! | -
- dev_ggplot2_args2 <- teal.widgets::ggplot2_args(- |
-
939 | -! | -
- labs = list(x = "", y = ""),- |
-
940 | -! | -
- theme = list(- |
-
941 | -! | -
- legend.position = "bottom",- |
-
942 | -! | -
- axis.text.x = quote(element_blank()),- |
-
943 | -! | -
- axis.ticks = quote(element_blank()),- |
-
944 | -! | -
- panel.grid.major = quote(element_blank())- |
-
945 | -- |
- )- |
-
946 | -- |
- )- |
-
947 | -- | - - | -
948 | -! | -
- all_ggplot2_args2 <- teal.widgets::resolve_ggplot2_args(- |
-
949 | -! | -
- user_plot = ggplot2_args[["Combinations Main"]],- |
-
950 | -! | -
- user_default = ggplot2_args$default,- |
-
951 | -! | -
- module_plot = dev_ggplot2_args2- |
-
952 | -- |
- )- |
-
953 | -- | - - | -
954 | -! | -
- parsed_ggplot2_args2 <- teal.widgets::parse_ggplot2_args(- |
-
955 | -! | -
- all_ggplot2_args2,- |
-
956 | -! | -
- ggtheme = input$ggtheme- |
-
957 | -- |
- )- |
-
958 | -- | - - | -
959 | -! | -
- teal.code::eval_code(- |
-
960 | -! | -
- qenv,- |
-
961 | -! | -
- substitute(- |
-
962 | -! | -
- expr = {- |
-
963 | -! | -
- p1 <- data_combination_plot_cutoff %>%- |
-
964 | -! | -
- dplyr::select(id, n) %>%- |
-
965 | -! | -
- dplyr::distinct() %>%- |
-
966 | -! | -
- ggplot(aes(x = id, y = n)) +- |
-
967 | -! | -
- geom_bar(stat = "identity", fill = c(getOption("ggplot2.discrete.colour")[2], "#ff2951ff")[1]) +- |
-
968 | -! | -
- geom_text(aes(label = n), position = position_dodge(width = 0.9), vjust = -0.25) +- |
-
969 | -! | -
- ylim(c(0, max(data_combination_plot_cutoff$n) * 1.5)) +- |
-
970 | -! | -
- labs1 +- |
-
971 | -! | -
- ggthemes1 +- |
-
972 | -! | -
- themes1- |
-
973 | -- | - - | -
974 | -! | -
- graph_number_rows <- length(unique(data_combination_plot_cutoff$id))- |
-
975 | -! | -
- graph_number_cols <- nrow(data_combination_plot_cutoff) / graph_number_rows- |
-
976 | -- | - - | -
977 | -! | -
- p2 <- data_combination_plot_cutoff %>% ggplot() +- |
-
978 | -! | -
- aes(x = create_cols_labels(key), y = id - 0.5, fill = value) +- |
-
979 | -! | -
- geom_tile(alpha = 0.85, height = 0.95) +- |
-
980 | -! | -
- scale_fill_manual(- |
-
981 | -! | -
- name = "",- |
-
982 | -! | -
- values = c("grey90", c(getOption("ggplot2.discrete.colour")[2], "#ff2951ff")[1]),- |
-
983 | -! | -
- labels = c("Present", "Missing")- |
-
984 | -- |
- ) +- |
-
985 | -! | -
- geom_hline(yintercept = seq_len(1 + graph_number_rows) - 1) +- |
-
986 | -! | -
- geom_vline(xintercept = seq_len(1 + graph_number_cols) - 0.5, linetype = "dotted") +- |
-
987 | -! | -
- coord_flip() +- |
-
988 | -! | -
- labs2 +- |
-
989 | -! | -
- ggthemes2 +- |
-
990 | -! | -
- themes2- |
-
991 | -- | - - | -
992 | -! | -
- g1 <- ggplotGrob(p1)- |
-
993 | -! | -
- g2 <- ggplotGrob(p2)- |
-
994 | -- | - - | -
995 | -! | -
- g <- gridExtra::gtable_rbind(g1, g2, size = "last")- |
-
996 | -! | -
- g$heights[7] <- grid::unit(0.2, "null") # rescale to get the bar chart smaller- |
-
997 | -! | -
- grid::grid.newpage()- |
-
998 | -! | -
- grid::grid.draw(g)- |
-
999 | -- |
- },- |
-
1000 | -! | -
- env = list(- |
-
1001 | -! | -
- labs1 = parsed_ggplot2_args1$labs,- |
-
1002 | -! | -
- themes1 = parsed_ggplot2_args1$theme,- |
-
1003 | -! | -
- ggthemes1 = parsed_ggplot2_args1$ggtheme,- |
-
1004 | -! | -
- labs2 = parsed_ggplot2_args2$labs,- |
-
1005 | -! | -
- themes2 = parsed_ggplot2_args2$theme,- |
-
1006 | -! | -
- ggthemes2 = parsed_ggplot2_args2$ggtheme- |
-
1007 | -- |
- )- |
-
1008 | -- |
- )- |
-
1009 | -- |
- )- |
-
1010 | -- |
- })- |
-
1011 | -- | - - | -
1012 | -! | -
- combination_plot_r <- reactive(combination_plot_q()[["g"]])- |
-
1013 | -- | - - | -
1014 | -! | -
- summary_table_q <- reactive({- |
-
1015 | -! | -
- req(- |
-
1016 | -! | -
- input$summary_type == "By Variable Levels", # needed to trigger show r code update on tab change- |
-
1017 | -! | -
- common_code_q()- |
-
1018 | -- |
- )- |
-
1019 | -! | -
- teal::validate_has_data(data_r(), 1)- |
-
1020 | -- | - - | -
1021 | -- |
- # extract the ANL dataset for use in further validation- |
-
1022 | -! | -
- anl <- common_code_q()[["ANL"]]- |
-
1023 | -- | - - | -
1024 | -! | -
- group_var <- input$group_by_var- |
-
1025 | -! | -
- validate(- |
-
1026 | -! | -
- need(- |
-
1027 | -! | -
- is.null(group_var) ||- |
-
1028 | -! | -
- length(unique(anl[[group_var]])) < 100,- |
-
1029 | -! | -
- "Please select group-by variable with fewer than 100 unique values"- |
-
1030 | -- |
- )- |
-
1031 | -- |
- )- |
-
1032 | -- | - - | -
1033 | -! | -
- group_vals <- input$group_by_vals- |
-
1034 | -! | -
- variables_select <- input$variables_select- |
-
1035 | -! | -
- vars <- unique(variables_select, group_var)- |
-
1036 | -! | -
- count_type <- input$count_type- |
-
1037 | -- | - - | -
1038 | -! | -
- if (!is.null(selected_vars()) && length(selected_vars()) != ncol(anl)) {- |
-
1039 | -! | -
- variables <- selected_vars()- |
-
1040 | -- |
- } else {- |
-
1041 | -! | -
- variables <- colnames(anl)- |
-
1042 | -- |
- }- |
-
1043 | -- | - - | -
1044 | -! | -
- summ_fn <- if (input$count_type == "counts") {- |
-
1045 | -! | -
- function(x) sum(is.na(x))- |
-
1046 | -- |
- } else {- |
-
1047 | -! | -
- function(x) round(sum(is.na(x)) / length(x), 4)- |
-
1048 | -- |
- }- |
-
1049 | -- | - - | -
1050 | -! | -
- qenv <- common_code_q()- |
-
1051 | -- | - - | -
1052 | -! | -
- if (!is.null(group_var)) {- |
-
1053 | -! | -
- qenv <- teal.code::eval_code(- |
-
1054 | -! | -
- qenv,- |
-
1055 | -! | -
- substitute(- |
-
1056 | -! | -
- expr = {- |
-
1057 | -! | -
- summary_data <- ANL %>%- |
-
1058 | -! | -
- dplyr::mutate(group_var_name := forcats::fct_na_value_to_level(as.factor(group_var_name), "NA")) %>%- |
-
1059 | -! | -
- dplyr::group_by_at(group_var) %>%- |
-
1060 | -! | -
- dplyr::filter(group_var_name %in% group_vals)- |
-
1061 | -- | - - | -
1062 | -! | -
- count_data <- dplyr::summarise(summary_data, n = dplyr::n())- |
-
1063 | -- | - - | -
1064 | -! | -
- summary_data <- dplyr::summarise_all(summary_data, summ_fn) %>%- |
-
1065 | -! | -
- dplyr::mutate(group_var_name := paste0(group_var, ":", group_var_name, "(N=", count_data$n, ")")) %>%- |
-
1066 | -! | -
- tidyr::pivot_longer(!dplyr::all_of(group_var), names_to = "Variable", values_to = "out") %>%- |
-
1067 | -! | -
- tidyr::pivot_wider(names_from = group_var, values_from = "out") %>%- |
-
1068 | -! | -
- dplyr::mutate(`Variable label` = create_cols_labels(Variable, just_label = TRUE), .after = Variable)- |
-
1069 | -- |
- },- |
-
1070 | -! | -
- env = list(- |
-
1071 | -! | -
- group_var = group_var, group_var_name = as.name(group_var), group_vals = group_vals, summ_fn = summ_fn- |
-
1072 | -- |
- )- |
-
1073 | -- |
- )- |
-
1074 | -- |
- )- |
-
1075 | -- |
- } else {- |
-
1076 | -! | -
- qenv <- teal.code::eval_code(- |
-
1077 | -! | -
- qenv,- |
-
1078 | -! | -
- substitute(- |
-
1079 | -! | -
- expr = summary_data <- ANL %>%- |
-
1080 | -! | -
- dplyr::summarise_all(summ_fn) %>%- |
-
1081 | -! | -
- tidyr::pivot_longer(dplyr::everything(),- |
-
1082 | -! | -
- names_to = "Variable",- |
-
1083 | -! | -
- values_to = paste0("Missing (N=", nrow(ANL), ")")- |
-
1084 | -- |
- ) %>%- |
-
1085 | -! | -
- dplyr::mutate(`Variable label` = create_cols_labels(Variable), .after = Variable),- |
-
1086 | -! | -
- env = list(summ_fn = summ_fn)- |
-
1087 | -- |
- )- |
-
1088 | -- |
- )- |
-
1089 | -- |
- }- |
-
1090 | -- | - - | -
1091 | -! | -
- teal.code::eval_code(qenv, quote(summary_data))- |
-
1092 | -- |
- })- |
-
1093 | -- | - - | -
1094 | -! | -
- summary_table_r <- reactive(summary_table_q()[["summary_data"]])- |
-
1095 | -- | - - | -
1096 | -! | -
- by_subject_plot_q <- reactive({- |
-
1097 | -- |
- # needed to trigger show r code update on tab change- |
-
1098 | -! | -
- req(input$summary_type == "Grouped by Subject", common_code_q())- |
-
1099 | -- | - - | -
1100 | -! | -
- teal::validate_has_data(data_r(), 1)- |
-
1101 | -- | - - | -
1102 | -! | -
- dev_ggplot2_args <- teal.widgets::ggplot2_args(- |
-
1103 | -! | -
- labs = list(x = "", y = ""),- |
-
1104 | -! | -
- theme = list(legend.position = "bottom", axis.text.x = quote(element_blank()))- |
-
1105 | -- |
- )- |
-
1106 | -- | - - | -
1107 | -! | -
- all_ggplot2_args <- teal.widgets::resolve_ggplot2_args(- |
-
1108 | -! | -
- user_plot = ggplot2_args[["By Subject"]],- |
-
1109 | -! | -
- user_default = ggplot2_args$default,- |
-
1110 | -! | -
- module_plot = dev_ggplot2_args- |
-
1111 | -- |
- )- |
-
1112 | -- | - - | -
1113 | -! | -
- parsed_ggplot2_args <- teal.widgets::parse_ggplot2_args(- |
-
1114 | -! | -
- all_ggplot2_args,- |
-
1115 | -! | -
- ggtheme = input$ggtheme- |
-
1116 | -- |
- )- |
-
1117 | -- | - - | -
1118 | -! | -
- teal.code::eval_code(- |
-
1119 | -! | -
- common_code_q(),- |
-
1120 | -! | -
- substitute(- |
-
1121 | -! | -
- expr = parent_keys <- keys,- |
-
1122 | -! | -
- env = list(keys = data_parent_keys())- |
-
1123 | -- |
- )- |
-
1124 | -- |
- ) %>%- |
-
1125 | -! | -
- teal.code::eval_code(- |
-
1126 | -! | -
- substitute(- |
-
1127 | -! | -
- expr = analysis_vars <- setdiff(colnames(ANL), data_keys),- |
-
1128 | -! | -
- env = list(data_keys = data_keys())- |
-
1129 | -- |
- )- |
-
1130 | -- |
- ) %>%- |
-
1131 | -! | -
- teal.code::eval_code(- |
-
1132 | -! | -
- quote({- |
-
1133 | -! | -
- summary_plot_patients <- ANL[, c(parent_keys, analysis_vars)] %>%- |
-
1134 | -! | -
- dplyr::group_by_at(parent_keys) %>%- |
-
1135 | -! | -
- dplyr::mutate(id = dplyr::cur_group_id()) %>%- |
-
1136 | -! | -
- dplyr::ungroup() %>%- |
-
1137 | -! | -
- dplyr::group_by_at(c(parent_keys, "id")) %>%- |
-
1138 | -! | -
- dplyr::summarise_all(anyNA) %>%- |
-
1139 | -! | -
- dplyr::ungroup()- |
-
1140 | -- | - - | -
1141 | -- |
- # order subjects by decreasing number of missing and then by- |
-
1142 | -- |
- # missingness pattern (defined using sha1)- |
-
1143 | -! | -
- order_subjects <- summary_plot_patients %>%- |
-
1144 | -! | -
- dplyr::select(-"id", -dplyr::all_of(parent_keys)) %>%- |
-
1145 | -! | -
- dplyr::transmute(- |
-
1146 | -! | -
- id = dplyr::row_number(),- |
-
1147 | -! | -
- number_NA = apply(., 1, sum),- |
-
1148 | -! | -
- sha = apply(., 1, rlang::hash)- |
-
1149 | -- |
- ) %>%- |
-
1150 | -! | -
- dplyr::arrange(dplyr::desc(number_NA), sha) %>%- |
-
1151 | -! | -
- getElement(name = "id")- |
-
1152 | -- | - - | -
1153 | -- |
- # order columns by decreasing percent of missing values- |
-
1154 | -! | -
- ordered_columns <- summary_plot_patients %>%- |
-
1155 | -! | -
- dplyr::select(-"id", -dplyr::all_of(parent_keys)) %>%- |
-
1156 | -! | -
- dplyr::summarise(- |
-
1157 | -! | -
- column = create_cols_labels(colnames(.)),- |
-
1158 | -! | -
- na_count = apply(., MARGIN = 2, FUN = sum),- |
-
1159 | -! | -
- na_percent = na_count / nrow(.) * 100- |
-
1160 | -- |
- ) %>%- |
-
1161 | -! | -
- dplyr::arrange(na_percent, dplyr::desc(column))- |
-
1162 | -- | - - | -
1163 | -! | -
- summary_plot_patients <- summary_plot_patients %>%- |
-
1164 | -! | -
- tidyr::gather("col", "isna", -"id", -dplyr::all_of(parent_keys)) %>%- |
-
1165 | -! | -
- dplyr::mutate(col = create_cols_labels(col))- |
-
1166 | -- |
- })- |
-
1167 | -- |
- ) %>%- |
-
1168 | -! | -
- teal.code::eval_code(- |
-
1169 | -! | -
- substitute(- |
-
1170 | -! | -
- expr = {- |
-
1171 | -! | -
- g <- ggplot(summary_plot_patients, aes(- |
-
1172 | -! | -
- x = factor(id, levels = order_subjects),- |
-
1173 | -! | -
- y = factor(col, levels = ordered_columns[["column"]]),- |
-
1174 | -! | -
- fill = isna- |
-
1175 | -- |
- )) +- |
-
1176 | -! | -
- geom_raster() +- |
-
1177 | -! | -
- annotate(- |
-
1178 | -! | -
- "text",- |
-
1179 | -! | -
- x = length(order_subjects),- |
-
1180 | -! | -
- y = seq_len(nrow(ordered_columns)),- |
-
1181 | -! | -
- hjust = 1,- |
-
1182 | -! | -
- label = sprintf("%d [%.02f%%]", ordered_columns[["na_count"]], ordered_columns[["na_percent"]])- |
-
1183 | -- |
- ) +- |
-
1184 | -! | -
- scale_fill_manual(- |
-
1185 | -! | -
- name = "",- |
-
1186 | -! | -
- values = c("grey90", c(getOption("ggplot2.discrete.colour")[2], "#ff2951ff")[1]),- |
-
1187 | -! | -
- labels = c("Present", "Missing (at least one)")- |
-
1188 | -- |
- ) +- |
-
1189 | -! | -
- labs +- |
-
1190 | -! | -
- ggthemes +- |
-
1191 | -! | -
- themes- |
-
1192 | -! | -
- print(g)- |
-
1193 | -- |
- },- |
-
1194 | -! | -
- env = list(- |
-
1195 | -! | -
- labs = parsed_ggplot2_args$labs,- |
-
1196 | -! | -
- themes = parsed_ggplot2_args$theme,- |
-
1197 | -! | -
- ggthemes = parsed_ggplot2_args$ggtheme- |
-
1198 | -- |
- )- |
-
1199 | -- |
- )- |
-
1200 | -- |
- )- |
-
1201 | -- |
- })- |
-
1202 | -- | - - | -
1203 | -! | -
- by_subject_plot_r <- reactive(by_subject_plot_q()[["g"]])- |
-
1204 | -- | - - | -
1205 | -! | -
- output$levels_table <- DT::renderDataTable(- |
-
1206 | -! | -
- expr = {- |
-
1207 | -! | -
- if (length(input$variables_select) == 0) {- |
-
1208 | -- |
- # so that zeroRecords message gets printed- |
-
1209 | -- |
- # using tibble as it supports weird column names, such as " "- |
-
1210 | -! | -
- tibble::tibble(` ` = logical(0))- |
-
1211 | -- |
- } else {- |
-
1212 | -! | -
- summary_table_r()- |
-
1213 | -- |
- }- |
-
1214 | -- |
- },- |
-
1215 | -! | -
- options = list(language = list(zeroRecords = "No variable selected"), pageLength = input$levels_table_rows)- |
-
1216 | -- |
- )- |
-
1217 | -- | - - | -
1218 | -! | -
- pws1 <- teal.widgets::plot_with_settings_srv(- |
-
1219 | -! | -
- id = "summary_plot",- |
-
1220 | -! | -
- plot_r = summary_plot_r,- |
-
1221 | -! | -
- height = plot_height,- |
-
1222 | -! | -
- width = plot_width- |
-
1223 | -- |
- )- |
-
1224 | -- | - - | -
1225 | -! | -
- pws2 <- teal.widgets::plot_with_settings_srv(- |
-
1226 | -! | -
- id = "combination_plot",- |
-
1227 | -! | -
- plot_r = combination_plot_r,- |
-
1228 | -! | -
- height = plot_height,- |
-
1229 | -! | -
- width = plot_width- |
-
1230 | -- |
- )- |
-
1231 | -- | - - | -
1232 | -! | -
- pws3 <- teal.widgets::plot_with_settings_srv(- |
-
1233 | -! | -
- id = "by_subject_plot",- |
-
1234 | -! | -
- plot_r = by_subject_plot_r,- |
-
1235 | -! | -
- height = plot_height,- |
-
1236 | -! | -
- width = plot_width- |
-
1237 | -- |
- )- |
-
1238 | -- | - - | -
1239 | -! | -
- final_q <- reactive({- |
-
1240 | -! | -
- req(input$summary_type)- |
-
1241 | -! | -
- sum_type <- input$summary_type- |
-
1242 | -! | -
- if (sum_type == "Summary") {- |
-
1243 | -! | -
- summary_plot_q()- |
-
1244 | -! | -
- } else if (sum_type == "Combinations") {- |
-
1245 | -! | -
- combination_plot_q()- |
-
1246 | -! | -
- } else if (sum_type == "By Variable Levels") {- |
-
1247 | -! | -
- summary_table_q()- |
-
1248 | -! | -
- } else if (sum_type == "Grouped by Subject") {- |
-
1249 | -! | -
- by_subject_plot_q()- |
-
1250 | -- |
- }- |
-
1251 | -- |
- })- |
-
1252 | -- | - - | -
1253 | -! | -
- teal.widgets::verbatim_popup_srv(- |
-
1254 | -! | -
- id = "warning",- |
-
1255 | -! | -
- verbatim_content = reactive(teal.code::get_warnings(final_q())),- |
-
1256 | -! | -
- title = "Warning",- |
-
1257 | -! | -
- disabled = reactive(is.null(teal.code::get_warnings(final_q())))- |
-
1258 | -- |
- )- |
-
1259 | -- | - - | -
1260 | -! | -
- teal.widgets::verbatim_popup_srv(- |
-
1261 | -! | -
- id = "rcode",- |
-
1262 | -! | -
- verbatim_content = reactive(teal.code::get_code(final_q())),- |
-
1263 | -! | -
- title = "Show R Code for Missing Data"- |
-
1264 | -- |
- )- |
-
1265 | -- | - - | -
1266 | -- |
- ### REPORTER- |
-
1267 | -! | -
- if (with_reporter) {- |
-
1268 | -! | -
- card_fun <- function(comment, label) {- |
-
1269 | -! | -
- card <- teal::TealReportCard$new()- |
-
1270 | -! | -
- sum_type <- input$summary_type- |
-
1271 | -! | -
- title <- if (sum_type == "By Variable Levels") paste0(sum_type, " Table") else paste0(sum_type, " Plot")- |
-
1272 | -! | -
- title_dataname <- paste(title, dataname, sep = " - ")- |
-
1273 | -! | -
- label <- if (label == "") {- |
-
1274 | -! | -
- paste("Missing Data", sum_type, dataname, sep = " - ")- |
-
1275 | -- |
- } else {- |
-
1276 | -! | -
- label- |
-
1277 | -- |
- }- |
-
1278 | -! | -
- card$set_name(label)- |
-
1279 | -! | -
- card$append_text(title_dataname, "header2")- |
-
1280 | -! | -
- if (with_filter) card$append_fs(filter_panel_api$get_filter_state())- |
-
1281 | -! | -
- if (sum_type == "Summary") {- |
-
1282 | -! | -
- card$append_text("Plot", "header3")- |
-
1283 | -! | -
- card$append_plot(summary_plot_r(), dim = pws1$dim())- |
-
1284 | -! | -
- } else if (sum_type == "Combinations") {- |
-
1285 | -! | -
- card$append_text("Plot", "header3")- |
-
1286 | -! | -
- card$append_plot(combination_plot_r(), dim = pws2$dim())- |
-
1287 | -! | -
- } else if (sum_type == "By Variable Levels") {- |
-
1288 | -! | -
- card$append_text("Table", "header3")- |
-
1289 | -! | -
- card$append_table(summary_table_r[["summary_data"]])- |
-
1290 | -! | -
- } else if (sum_type == "Grouped by Subject") {- |
-
1291 | -! | -
- card$append_text("Plot", "header3")- |
-
1292 | -! | -
- card$append_plot(by_subject_plot_r(), dim = pws3$dim())- |
-
1293 | -- |
- }- |
-
1294 | -! | -
- if (!comment == "") {- |
-
1295 | -! | -
- card$append_text("Comment", "header3")- |
-
1296 | -! | -
- card$append_text(comment)- |
-
1297 | -- |
- }- |
-
1298 | -! | -
- card$append_src(teal.code::get_code(final_q()))- |
-
1299 | -! | -
- card- |
-
1300 | -- |
- }- |
-
1301 | -! | -
- teal.reporter::simple_reporter_srv("simple_reporter", reporter = reporter, card_fun = card_fun)- |
-
1302 | -- |
- }- |
-
1303 | -- |
- ###- |
-
1304 | -- |
- })- |
-
1305 | -- |
- }- |
-
1 | -- |
- #' `teal` module: Outliers analysis- |
-
2 | -- |
- #'- |
-
3 | -- |
- #' Module to analyze and identify outliers using different methods- |
-
4 | -- |
- #' such as IQR, Z-score, and Percentiles, and offers visualizations including- |
-
5 | -- |
- #' box plots, density plots, and cumulative distribution plots to help interpret the outliers.- |
-
6 | -- |
- #'- |
-
7 | -- |
- #' @inheritParams teal::module- |
-
8 | -- |
- #' @inheritParams shared_params- |
-
9 | -- |
- #'- |
-
10 | -- |
- #' @param outlier_var (`data_extract_spec` or `list` of multiple `data_extract_spec`)- |
-
11 | -- |
- #' Specifies variable(s) to be analyzed for outliers.- |
-
12 | -- |
- #' @param categorical_var (`data_extract_spec` or `list` of multiple `data_extract_spec`) optional,- |
-
13 | -- |
- #' specifies the categorical variable(s) to split the selected outlier variables on.- |
-
14 | -- |
- #'- |
-
15 | -- |
- #' @templateVar ggnames "Boxplot","Density Plot","Cumulative Distribution Plot"- |
-
16 | -- |
- #' @template ggplot2_args_multi- |
-
17 | -- |
- #'- |
-
18 | -- |
- #' @inherit shared_params return- |
-
19 | -- |
- #'- |
-
20 | -- |
- #' @examples- |
-
21 | -- |
- #' library(teal.widgets)- |
-
22 | -- |
- #'- |
-
23 | -- |
- #' # general data example- |
-
24 | -- |
- #' data <- teal_data()- |
-
25 | -- |
- #' data <- within(data, {- |
-
26 | -- |
- #' CO2 <- CO2- |
-
27 | -- |
- #' CO2[["primary_key"]] <- seq_len(nrow(CO2))- |
-
28 | -- |
- #' })- |
-
29 | -- |
- #' datanames(data) <- "CO2"- |
-
30 | -- |
- #' join_keys(data) <- join_keys(join_key("CO2", "CO2", "primary_key"))- |
-
31 | -- |
- #'- |
-
32 | -- |
- #' vars <- choices_selected(variable_choices(data[["CO2"]], c("Plant", "Type", "Treatment")))- |
-
33 | -- |
- #'- |
-
34 | -- |
- #' app <- init(- |
-
35 | -- |
- #' data = data,- |
-
36 | -- |
- #' modules = modules(- |
-
37 | -- |
- #' tm_outliers(- |
-
38 | -- |
- #' outlier_var = list(- |
-
39 | -- |
- #' data_extract_spec(- |
-
40 | -- |
- #' dataname = "CO2",- |
-
41 | -- |
- #' select = select_spec(- |
-
42 | -- |
- #' label = "Select variable:",- |
-
43 | -- |
- #' choices = variable_choices(data[["CO2"]], c("conc", "uptake")),- |
-
44 | -- |
- #' selected = "uptake",- |
-
45 | -- |
- #' multiple = FALSE,- |
-
46 | -- |
- #' fixed = FALSE- |
-
47 | -- |
- #' )- |
-
48 | -- |
- #' )- |
-
49 | -- |
- #' ),- |
-
50 | -- |
- #' categorical_var = list(- |
-
51 | -- |
- #' data_extract_spec(- |
-
52 | -- |
- #' dataname = "CO2",- |
-
53 | -- |
- #' filter = filter_spec(- |
-
54 | -- |
- #' vars = vars,- |
-
55 | -- |
- #' choices = value_choices(data[["CO2"]], vars$selected),- |
-
56 | -- |
- #' selected = value_choices(data[["CO2"]], vars$selected),- |
-
57 | -- |
- #' multiple = TRUE- |
-
58 | -- |
- #' )- |
-
59 | -- |
- #' )- |
-
60 | -- |
- #' ),- |
-
61 | -- |
- #' ggplot2_args = list(- |
-
62 | -- |
- #' ggplot2_args(- |
-
63 | -- |
- #' labs = list(subtitle = "Plot generated by Outliers Module")- |
-
64 | -- |
- #' )- |
-
65 | -- |
- #' )- |
-
66 | -- |
- #' )- |
-
67 | -- |
- #' )- |
-
68 | -- |
- #' )- |
-
69 | -- |
- #' if (interactive()) {- |
-
70 | -- |
- #' shinyApp(app$ui, app$server)- |
-
71 | -- |
- #' }- |
-
72 | -- |
- #'- |
-
73 | -- |
- #' # CDISC data example- |
-
74 | -- |
- #' data <- teal_data()- |
-
75 | -- |
- #' data <- within(data, {- |
-
76 | -- |
- #' ADSL <- rADSL- |
-
77 | -- |
- #' })- |
-
78 | -- |
- #' datanames(data) <- "ADSL"- |
-
79 | -- |
- #' join_keys(data) <- default_cdisc_join_keys[datanames(data)]- |
-
80 | -- |
- #'- |
-
81 | -- |
- #' fact_vars_adsl <- names(Filter(isTRUE, sapply(data[["ADSL"]], is.factor)))- |
-
82 | -- |
- #' vars <- choices_selected(variable_choices(data[["ADSL"]], fact_vars_adsl))- |
-
83 | -- |
- #'- |
-
84 | -- |
- #' app <- init(- |
-
85 | -- |
- #' data = data,- |
-
86 | -- |
- #' modules = modules(- |
-
87 | -- |
- #' tm_outliers(- |
-
88 | -- |
- #' outlier_var = list(- |
-
89 | -- |
- #' data_extract_spec(- |
-
90 | -- |
- #' dataname = "ADSL",- |
-
91 | -- |
- #' select = select_spec(- |
-
92 | -- |
- #' label = "Select variable:",- |
-
93 | -- |
- #' choices = variable_choices(data[["ADSL"]], c("AGE", "BMRKR1")),- |
-
94 | -- |
- #' selected = "AGE",- |
-
95 | -- |
- #' multiple = FALSE,- |
-
96 | -- |
- #' fixed = FALSE- |
-
97 | -- |
- #' )- |
-
98 | -- |
- #' )- |
-
99 | -- |
- #' ),- |
-
100 | -- |
- #' categorical_var = list(- |
-
101 | -- |
- #' data_extract_spec(- |
-
102 | -- |
- #' dataname = "ADSL",- |
-
103 | -- |
- #' filter = filter_spec(- |
-
104 | -- |
- #' vars = vars,- |
-
105 | -- |
- #' choices = value_choices(data[["ADSL"]], vars$selected),- |
-
106 | -- |
- #' selected = value_choices(data[["ADSL"]], vars$selected),- |
-
107 | -- |
- #' multiple = TRUE- |
-
108 | -- |
- #' )- |
-
109 | -- |
- #' )- |
-
110 | -- |
- #' ),- |
-
111 | -- |
- #' ggplot2_args = list(- |
-
112 | -- |
- #' ggplot2_args(- |
-
113 | -- |
- #' labs = list(subtitle = "Plot generated by Outliers Module")- |
-
114 | -- |
- #' )- |
-
115 | -- |
- #' )- |
-
116 | -- |
- #' )- |
-
117 | -- |
- #' )- |
-
118 | -- |
- #' )- |
-
119 | -- |
- #' if (interactive()) {- |
-
120 | -- |
- #' shinyApp(app$ui, app$server)- |
-
121 | -- |
- #' }- |
-
122 | -- |
- #'- |
-
123 | -- |
- #' @export- |
-
124 | -- |
- #'- |
-
125 | -- |
- tm_outliers <- function(label = "Outliers Module",- |
-
126 | -- |
- outlier_var,- |
-
127 | -- |
- categorical_var = NULL,- |
-
128 | -- |
- ggtheme = c("gray", "bw", "linedraw", "light", "dark", "minimal", "classic", "void"),- |
-
129 | -- |
- ggplot2_args = teal.widgets::ggplot2_args(),- |
-
130 | -- |
- plot_height = c(600, 200, 2000),- |
-
131 | -- |
- plot_width = NULL,- |
-
132 | -- |
- pre_output = NULL,- |
-
133 | -- |
- post_output = NULL) {- |
-
134 | -! | -
- logger::log_info("Initializing tm_outliers")- |
-
135 | -- | - - | -
136 | -- |
- # Normalize the parameters- |
-
137 | -! | -
- if (inherits(outlier_var, "data_extract_spec")) outlier_var <- list(outlier_var)- |
-
138 | -! | -
- if (inherits(categorical_var, "data_extract_spec")) categorical_var <- list(categorical_var)- |
-
139 | -! | -
- if (inherits(ggplot2_args, "ggplot2_args")) ggplot2_args <- list(default = ggplot2_args)- |
-
140 | -- | - - | -
141 | -- |
- # Start of assertions- |
-
142 | -! | -
- checkmate::assert_string(label)- |
-
143 | -! | -
- checkmate::assert_list(outlier_var, types = "data_extract_spec")- |
-
144 | -- | - - | -
145 | -! | -
- checkmate::assert_list(categorical_var, types = "data_extract_spec", null.ok = TRUE)- |
-
146 | -! | -
- if (is.list(categorical_var)) {- |
-
147 | -! | -
- lapply(categorical_var, function(x) {- |
-
148 | -! | -
- if (length(x$filter) > 1L) {- |
-
149 | -! | -
- stop("tm_outliers: categorical_var data_extract_specs may only specify one filter_spec", call. = FALSE)- |
-
150 | -- |
- }- |
-
151 | -- |
- })- |
-
152 | -- |
- }- |
-
153 | -- | - - | -
154 | -! | -
- ggtheme <- match.arg(ggtheme)- |
-
155 | -- | - - | -
156 | -! | -
- plot_choices <- c("Boxplot", "Density Plot", "Cumulative Distribution Plot")- |
-
157 | -! | -
- checkmate::assert_list(ggplot2_args, types = "ggplot2_args")- |
-
158 | -! | -
- checkmate::assert_subset(names(ggplot2_args), c("default", plot_choices))- |
-
159 | -- | - - | -
160 | -! | -
- checkmate::assert_numeric(plot_height, len = 3, any.missing = FALSE, finite = TRUE)- |
-
161 | -! | -
- checkmate::assert_numeric(plot_height[1], lower = plot_height[2], upper = plot_height[3], .var.name = "plot_height")- |
-
162 | -! | -
- checkmate::assert_numeric(plot_width, len = 3, any.missing = FALSE, null.ok = TRUE, finite = TRUE)- |
-
163 | -! | -
- checkmate::assert_numeric(- |
-
164 | -! | -
- plot_width[1],- |
-
165 | -! | -
- lower = plot_width[2], upper = plot_width[3], null.ok = TRUE, .var.name = "plot_width"- |
-
166 | -- |
- )- |
-
167 | -- | - - | -
168 | -! | -
- checkmate::assert_multi_class(pre_output, c("shiny.tag", "shiny.tag.list", "html"), null.ok = TRUE)- |
-
169 | -! | -
- checkmate::assert_multi_class(post_output, c("shiny.tag", "shiny.tag.list", "html"), null.ok = TRUE)- |
-
170 | -- |
- # End of assertions- |
-
171 | -- | - - | -
172 | -- |
- # Make UI args- |
-
173 | -! | -
- args <- as.list(environment())- |
-
174 | -- | - - | -
175 | -! | -
- data_extract_list <- list(- |
-
176 | -! | -
- outlier_var = outlier_var,- |
-
177 | -! | -
- categorical_var = categorical_var- |
-
178 | -- |
- )- |
-
179 | -- | - - | -
180 | -! | -
- module(- |
-
181 | -! | -
- label = label,- |
-
182 | -! | -
- server = srv_outliers,- |
-
183 | -! | -
- server_args = c(- |
-
184 | -! | -
- data_extract_list,- |
-
185 | -! | -
- list(plot_height = plot_height, plot_width = plot_width, ggplot2_args = ggplot2_args)- |
-
186 | -- |
- ),- |
-
187 | -! | -
- ui = ui_outliers,- |
-
188 | -! | -
- ui_args = args,- |
-
189 | -! | -
- datanames = teal.transform::get_extract_datanames(data_extract_list)- |
-
190 | -- |
- )- |
-
191 | -- |
- }- |
-
192 | -- | - - | -
193 | -- |
- # UI function for the outliers module- |
-
194 | -- |
- ui_outliers <- function(id, ...) {- |
-
195 | -! | -
- args <- list(...)- |
-
196 | -! | -
- ns <- NS(id)- |
-
197 | -! | -
- is_single_dataset_value <- teal.transform::is_single_dataset(args$outlier_var, args$categorical_var)- |
-
198 | -- | - - | -
199 | -! | -
- teal.widgets::standard_layout(- |
-
200 | -! | -
- output = teal.widgets::white_small_well(- |
-
201 | -! | -
- uiOutput(ns("total_outliers")),- |
-
202 | -! | -
- DT::dataTableOutput(ns("summary_table")),- |
-
203 | -! | -
- uiOutput(ns("total_missing")),- |
-
204 | -! | -
- br(), hr(),- |
-
205 | -! | -
- tabsetPanel(- |
-
206 | -! | -
- id = ns("tabs"),- |
-
207 | -! | -
- tabPanel(- |
-
208 | -! | -
- "Boxplot",- |
-
209 | -! | -
- teal.widgets::plot_with_settings_ui(id = ns("box_plot"))- |
-
210 | -- |
- ),- |
-
211 | -! | -
- tabPanel(- |
-
212 | -! | -
- "Density Plot",- |
-
213 | -! | -
- teal.widgets::plot_with_settings_ui(id = ns("density_plot"))- |
-
214 | -- |
- ),- |
-
215 | -! | -
- tabPanel(- |
-
216 | -! | -
- "Cumulative Distribution Plot",- |
-
217 | -! | -
- teal.widgets::plot_with_settings_ui(id = ns("cum_density_plot"))- |
-
218 | -- |
- )- |
-
219 | -- |
- ),- |
-
220 | -! | -
- br(), hr(),- |
-
221 | -! | -
- uiOutput(ns("table_ui_wrap")),- |
-
222 | -! | -
- DT::dataTableOutput(ns("table_ui"))- |
-
223 | -- |
- ),- |
-
224 | -! | -
- encoding = div(- |
-
225 | -- |
- ### Reporter- |
-
226 | -! | -
- teal.reporter::simple_reporter_ui(ns("simple_reporter")),- |
-
227 | -- |
- ###- |
-
228 | -! | -
- tags$label("Encodings", class = "text-primary"),- |
-
229 | -! | -
- teal.transform::datanames_input(args[c("outlier_var", "categorical_var")]),- |
-
230 | -! | -
- teal.transform::data_extract_ui(- |
-
231 | -! | -
- id = ns("outlier_var"),- |
-
232 | -! | -
- label = "Variable",- |
-
233 | -! | -
- data_extract_spec = args$outlier_var,- |
-
234 | -! | -
- is_single_dataset = is_single_dataset_value- |
-
235 | -- |
- ),- |
-
236 | -! | -
- if (!is.null(args$categorical_var)) {- |
-
237 | -! | -
- teal.transform::data_extract_ui(- |
-
238 | -! | -
- id = ns("categorical_var"),- |
-
239 | -! | -
- label = "Categorical factor",- |
-
240 | -! | -
- data_extract_spec = args$categorical_var,- |
-
241 | -! | -
- is_single_dataset = is_single_dataset_value- |
-
242 | -- |
- )- |
-
243 | -- |
- },- |
-
244 | -! | -
- conditionalPanel(- |
-
245 | -! | -
- condition = paste0("input['", ns("tabs"), "'] == 'Boxplot'"),- |
-
246 | -! | -
- teal.widgets::optionalSelectInput(- |
-
247 | -! | -
- inputId = ns("boxplot_alts"),- |
-
248 | -! | -
- label = "Plot type",- |
-
249 | -! | -
- choices = c("Box plot", "Violin plot"),- |
-
250 | -! | -
- selected = "Box plot",- |
-
251 | -! | -
- multiple = FALSE- |
-
252 | -- |
- )- |
-
253 | -- |
- ),- |
-
254 | -! | -
- shinyjs::hidden(checkboxInput(ns("split_outliers"), "Define outliers based on group splitting", value = FALSE)),- |
-
255 | -! | -
- shinyjs::hidden(checkboxInput(ns("order_by_outlier"), "Re-order categories by outliers [by %]", value = FALSE)),- |
-
256 | -! | -
- teal.widgets::panel_group(- |
-
257 | -! | -
- teal.widgets::panel_item(- |
-
258 | -! | -
- title = "Method parameters",- |
-
259 | -! | -
- collapsed = FALSE,- |
-
260 | -! | -
- teal.widgets::optionalSelectInput(- |
-
261 | -! | -
- inputId = ns("method"),- |
-
262 | -! | -
- label = "Method",- |
-
263 | -! | -
- choices = c("IQR", "Z-score", "Percentile"),- |
-
264 | -! | -
- selected = "IQR",- |
-
265 | -! | -
- multiple = FALSE- |
-
266 | -- |
- ),- |
-
267 | -! | -
- conditionalPanel(- |
-
268 | -! | -
- condition =- |
-
269 | -! | -
- paste0("input['", ns("method"), "'] == 'IQR'"),- |
-
270 | -! | -
- sliderInput(- |
-
271 | -! | -
- ns("iqr_slider"),- |
-
272 | -! | -
- "Outlier range:",- |
-
273 | -! | -
- min = 1,- |
-
274 | -! | -
- max = 5,- |
-
275 | -! | -
- value = 3,- |
-
276 | -! | -
- step = 0.5- |
-
277 | -- |
- )- |
-
278 | -- |
- ),- |
-
279 | -! | -
- conditionalPanel(- |
-
280 | -! | -
- condition =- |
-
281 | -! | -
- paste0("input['", ns("method"), "'] == 'Z-score'"),- |
-
282 | -! | -
- sliderInput(- |
-
283 | -! | -
- ns("zscore_slider"),- |
-
284 | -! | -
- "Outlier range:",- |
-
285 | -! | -
- min = 1,- |
-
286 | -! | -
- max = 5,- |
-
287 | -! | -
- value = 3,- |
-
288 | -! | -
- step = 0.5- |
-
289 | -- |
- )- |
-
290 | -- |
- ),- |
-
291 | -! | -
- conditionalPanel(- |
-
292 | -! | -
- condition =- |
-
293 | -! | -
- paste0("input['", ns("method"), "'] == 'Percentile'"),- |
-
294 | -! | -
- sliderInput(- |
-
295 | -! | -
- ns("percentile_slider"),- |
-
296 | -! | -
- "Outlier range:",- |
-
297 | -! | -
- min = 0.001,- |
-
298 | -! | -
- max = 0.5,- |
-
299 | -! | -
- value = 0.01,- |
-
300 | -! | -
- step = 0.001- |
-
301 | -- |
- )- |
-
302 | -- |
- ),- |
-
303 | -! | -
- uiOutput(ns("ui_outlier_help"))- |
-
304 | -- |
- )- |
-
305 | -- |
- ),- |
-
306 | -! | -
- teal.widgets::panel_item(- |
-
307 | -! | -
- title = "Plot settings",- |
-
308 | -! | -
- selectInput(- |
-
309 | -! | -
- inputId = ns("ggtheme"),- |
-
310 | -! | -
- label = "Theme (by ggplot):",- |
-
311 | -! | -
- choices = ggplot_themes,- |
-
312 | -! | -
- selected = args$ggtheme,- |
-
313 | -! | -
- multiple = FALSE- |
-
314 | -- |
- )- |
-
315 | -- |
- )- |
-
316 | -- |
- ),- |
-
317 | -! | -
- forms = tagList(- |
-
318 | -! | -
- teal.widgets::verbatim_popup_ui(ns("warning"), "Show Warnings"),- |
-
319 | -! | -
- teal.widgets::verbatim_popup_ui(ns("rcode"), "Show R code")- |
-
320 | -- |
- ),- |
-
321 | -! | -
- pre_output = args$pre_output,- |
-
322 | -! | -
- post_output = args$post_output- |
-
323 | -- |
- )- |
-
324 | -- |
- }- |
-
325 | -- | - - | -
326 | -- |
- # Server function for the outliers module- |
-
327 | -- |
- srv_outliers <- function(id, data, reporter, filter_panel_api, outlier_var,- |
-
328 | -- |
- categorical_var, plot_height, plot_width, ggplot2_args) {- |
-
329 | -! | -
- with_reporter <- !missing(reporter) && inherits(reporter, "Reporter")- |
-
330 | -! | -
- with_filter <- !missing(filter_panel_api) && inherits(filter_panel_api, "FilterPanelAPI")- |
-
331 | -! | -
- checkmate::assert_class(data, "reactive")- |
-
332 | -! | -
- checkmate::assert_class(isolate(data()), "teal_data")- |
-
333 | -! | -
- moduleServer(id, function(input, output, session) {- |
-
334 | -! | -
- vars <- list(outlier_var = outlier_var, categorical_var = categorical_var)- |
-
335 | -- | - - | -
336 | -! | -
- rule_diff <- function(other) {- |
-
337 | -! | -
- function(value) {- |
-
338 | -! | -
- othervalue <- tryCatch(selector_list()[[other]]()[["select"]], error = function(e) NULL)- |
-
339 | -! | -
- if (!is.null(othervalue) && identical(othervalue, value)) {- |
-
340 | -! | -
- "`Variable` and `Categorical factor` cannot be the same"- |
-
341 | -- |
- }- |
-
342 | -- |
- }- |
-
343 | -- |
- }- |
-
344 | -- | - - | -
345 | -! | -
- selector_list <- teal.transform::data_extract_multiple_srv(- |
-
346 | -! | -
- data_extract = vars,- |
-
347 | -! | -
- datasets = data,- |
-
348 | -! | -
- select_validation_rule = list(- |
-
349 | -! | -
- outlier_var = shinyvalidate::compose_rules(- |
-
350 | -! | -
- shinyvalidate::sv_required("Please select a variable"),- |
-
351 | -! | -
- rule_diff("categorical_var")- |
-
352 | -- |
- ),- |
-
353 | -! | -
- categorical_var = rule_diff("outlier_var")- |
-
354 | -- |
- )- |
-
355 | -- |
- )- |
-
356 | -- | - - | -
357 | -! | -
- iv_r <- reactive({- |
-
358 | -! | -
- iv <- shinyvalidate::InputValidator$new()- |
-
359 | -! | -
- iv$add_rule("method", shinyvalidate::sv_required("Please select a method"))- |
-
360 | -! | -
- iv$add_rule("boxplot_alts", shinyvalidate::sv_required("Please select Plot Type"))- |
-
361 | -! | -
- teal.transform::compose_and_enable_validators(iv, selector_list)- |
-
362 | -- |
- })- |
-
363 | -- | - - | -
364 | -! | -
- reactive_select_input <- reactive({- |
-
365 | -! | -
- if (is.null(selector_list()$categorical_var) || length(selector_list()$categorical_var()$select) == 0) {- |
-
366 | -! | -
- selector_list()[names(selector_list()) != "categorical_var"]- |
-
367 | -- |
- } else {- |
-
368 | -! | -
- selector_list()- |
-
369 | -- |
- }- |
-
370 | -- |
- })- |
-
371 | -- | - - | -
372 | -! | -
- anl_merged_input <- teal.transform::merge_expression_srv(- |
-
373 | -! | -
- selector_list = reactive_select_input,- |
-
374 | -! | -
- datasets = data,- |
-
375 | -! | -
- merge_function = "dplyr::inner_join"- |
-
376 | -- |
- )- |
-
377 | -- | - - | -
378 | -! | -
- anl_merged_q <- reactive({- |
-
379 | -! | -
- req(anl_merged_input())- |
-
380 | -! | -
- data() %>%- |
-
381 | -! | -
- teal.code::eval_code(as.expression(anl_merged_input()$expr))- |
-
382 | -- |
- })- |
-
383 | -- | - - | -
384 | -! | -
- merged <- list(- |
-
385 | -! | -
- anl_input_r = anl_merged_input,- |
-
386 | -! | -
- anl_q_r = anl_merged_q- |
-
387 | -- |
- )- |
-
388 | -- | - - | -
389 | -! | -
- n_outlier_missing <- reactive({- |
-
390 | -! | -
- shiny::req(iv_r()$is_valid())- |
-
391 | -! | -
- outlier_var <- as.vector(merged$anl_input_r()$columns_source$outlier_var)- |
-
392 | -! | -
- ANL <- merged$anl_q_r()[["ANL"]]- |
-
393 | -! | -
- sum(is.na(ANL[[outlier_var]]))- |
-
394 | -- |
- })- |
-
395 | -- | - - | -
396 | -- |
- # Used to create outlier table and the dropdown with additional columns- |
-
397 | -! | -
- dataname_first <- isolate(teal.data::datanames(data())[[1]])- |
-
398 | -- | - - | -
399 | -! | -
- common_code_q <- reactive({- |
-
400 | -! | -
- shiny::req(iv_r()$is_valid())- |
-
401 | -- | - - | -
402 | -! | -
- ANL <- merged$anl_q_r()[["ANL"]]- |
-
403 | -! | -
- qenv <- merged$anl_q_r()- |
-
404 | -- | - - | -
405 | -! | -
- outlier_var <- as.vector(merged$anl_input_r()$columns_source$outlier_var)- |
-
406 | -! | -
- categorical_var <- as.vector(merged$anl_input_r()$columns_source$categorical_var)- |
-
407 | -! | -
- order_by_outlier <- input$order_by_outlier- |
-
408 | -! | -
- method <- input$method- |
-
409 | -! | -
- split_outliers <- input$split_outliers- |
-
410 | -! | -
- teal::validate_has_data(- |
-
411 | -- |
- # missing values in the categorical variable may be used to form a category of its own- |
-
412 | -! | -
- `if`(- |
-
413 | -! | -
- length(categorical_var) == 0,- |
-
414 | -! | -
- ANL,- |
-
415 | -! | -
- ANL[, names(ANL) != categorical_var, drop = FALSE]- |
-
416 | -- |
- ),- |
-
417 | -! | -
- min_nrow = 10,- |
-
418 | -! | -
- complete = TRUE,- |
-
419 | -! | -
- allow_inf = FALSE- |
-
420 | -- |
- )- |
-
421 | -! | -
- validate(need(is.numeric(ANL[[outlier_var]]), "`Variable` is not numeric"))- |
-
422 | -! | -
- validate(need(length(unique(ANL[[outlier_var]])) > 1, "Variable has no variation, i.e. only one unique value"))- |
-
423 | -- | - - | -
424 | -- |
- # show/hide split_outliers- |
-
425 | -! | -
- if (length(categorical_var) == 0) {- |
-
426 | -! | -
- shinyjs::hide("split_outliers")- |
-
427 | -! | -
- if (n_outlier_missing() > 0) {- |
-
428 | -! | -
- qenv <- teal.code::eval_code(- |
-
429 | -! | -
- qenv,- |
-
430 | -! | -
- substitute(- |
-
431 | -! | -
- expr = ANL <- ANL %>% dplyr::filter(!is.na(outlier_var_name)),- |
-
432 | -! | -
- env = list(outlier_var_name = as.name(outlier_var))- |
-
433 | -- |
- )- |
-
434 | -- |
- )- |
-
435 | -- |
- }- |
-
436 | -- |
- } else {- |
-
437 | -! | -
- validate(need(- |
-
438 | -! | -
- is.factor(ANL[[categorical_var]]) ||- |
-
439 | -! | -
- is.character(ANL[[categorical_var]]) ||- |
-
440 | -! | -
- is.integer(ANL[[categorical_var]]),- |
-
441 | -! | -
- "`Categorical factor` must be `factor`, `character`, or `integer`"- |
-
442 | -- |
- ))- |
-
443 | -- | - - | -
444 | -! | -
- if (n_outlier_missing() > 0) {- |
-
445 | -! | -
- qenv <- teal.code::eval_code(- |
-
446 | -! | -
- qenv,- |
-
447 | -! | -
- substitute(- |
-
448 | -! | -
- expr = ANL <- ANL %>% dplyr::filter(!is.na(outlier_var_name)),- |
-
449 | -! | -
- env = list(outlier_var_name = as.name(outlier_var))- |
-
450 | -- |
- )- |
-
451 | -- |
- )- |
-
452 | -- |
- }- |
-
453 | -! | -
- shinyjs::show("split_outliers")- |
-
454 | -- |
- }- |
-
455 | -- | - - | -
456 | -- |
- # slider- |
-
457 | -! | -
- outlier_definition_param <- if (method == "IQR") {- |
-
458 | -! | -
- input$iqr_slider- |
-
459 | -! | -
- } else if (method == "Z-score") {- |
-
460 | -! | -
- input$zscore_slider- |
-
461 | -! | -
- } else if (method == "Percentile") {- |
-
462 | -! | -
- input$percentile_slider- |
-
463 | -- |
- }- |
-
464 | -- | - - | -
465 | -- |
- # this is utils function that converts a %>% NULL %>% b into a %>% b- |
-
466 | -! | -
- remove_pipe_null <- function(x) {- |
-
467 | -! | -
- if (length(x) == 1) {- |
-
468 | -! | -
- return(x)- |
-
469 | -- |
- }- |
-
470 | -! | -
- if (identical(x[[1]], as.name("%>%")) && is.null(x[[3]])) {- |
-
471 | -! | -
- return(remove_pipe_null(x[[2]]))- |
-
472 | -- |
- }- |
-
473 | -! | -
- return(as.call(c(x[[1]], lapply(x[-1], remove_pipe_null))))- |
-
474 | -- |
- }- |
-
475 | -- | - - | -
476 | -! | -
- qenv <- teal.code::eval_code(- |
-
477 | -! | -
- qenv,- |
-
478 | -! | -
- substitute(- |
-
479 | -! | -
- expr = {- |
-
480 | -! | -
- ANL_OUTLIER <- ANL %>%- |
-
481 | -! | -
- group_expr %>% # styler: off- |
-
482 | -! | -
- dplyr::mutate(is_outlier = {- |
-
483 | -! | -
- q1_q3 <- stats::quantile(outlier_var_name, probs = c(0.25, 0.75))- |
-
484 | -! | -
- iqr <- q1_q3[2] - q1_q3[1]- |
-
485 | -! | -
- !(outlier_var_name >= q1_q3[1] - 1.5 * iqr & outlier_var_name <= q1_q3[2] + 1.5 * iqr)- |
-
486 | -- |
- }) %>%- |
-
487 | -! | -
- calculate_outliers %>% # styler: off- |
-
488 | -! | -
- ungroup_expr %>% # styler: off- |
-
489 | -! | -
- dplyr::filter(is_outlier | is_outlier_selected) %>%- |
-
490 | -! | -
- dplyr::select(-is_outlier)- |
-
491 | -- |
- },- |
-
492 | -! | -
- env = list(- |
-
493 | -! | -
- calculate_outliers = if (method == "IQR") {- |
-
494 | -! | -
- substitute(- |
-
495 | -! | -
- expr = dplyr::mutate(is_outlier_selected = {- |
-
496 | -! | -
- q1_q3 <- stats::quantile(outlier_var_name, probs = c(0.25, 0.75))- |
-
497 | -! | -
- iqr <- q1_q3[2] - q1_q3[1]- |
-
498 | -- |
- !(- |
-
499 | -! | -
- outlier_var_name >= q1_q3[1] - outlier_definition_param * iqr &- |
-
500 | -! | -
- outlier_var_name <= q1_q3[2] + outlier_definition_param * iqr- |
-
501 | -- |
- )- |
-
502 | -- |
- }),- |
-
503 | -! | -
- env = list(- |
-
504 | -! | -
- outlier_var_name = as.name(outlier_var),- |
-
505 | -! | -
- outlier_definition_param = outlier_definition_param- |
-
506 | -- |
- )- |
-
507 | -- |
- )- |
-
508 | -! | -
- } else if (method == "Z-score") {- |
-
509 | -! | -
- substitute(- |
-
510 | -! | -
- expr = dplyr::mutate(- |
-
511 | -! | -
- is_outlier_selected = abs(outlier_var_name - mean(outlier_var_name)) /- |
-
512 | -! | -
- stats::sd(outlier_var_name) > outlier_definition_param- |
-
513 | -- |
- ),- |
-
514 | -! | -
- env = list(- |
-
515 | -! | -
- outlier_var_name = as.name(outlier_var),- |
-
516 | -! | -
- outlier_definition_param = outlier_definition_param- |
-
517 | -- |
- )- |
-
518 | -- |
- )- |
-
519 | -! | -
- } else if (method == "Percentile") {- |
-
520 | -! | -
- substitute(- |
-
521 | -! | -
- expr = dplyr::mutate(- |
-
522 | -! | -
- is_outlier_selected = outlier_var_name < stats::quantile(outlier_var_name, outlier_definition_param) |- |
-
523 | -! | -
- outlier_var_name > stats::quantile(outlier_var_name, 1 - outlier_definition_param)- |
-
524 | -- |
- ),- |
-
525 | -! | -
- env = list(- |
-
526 | -! | -
- outlier_var_name = as.name(outlier_var),- |
-
527 | -! | -
- outlier_definition_param = outlier_definition_param- |
-
528 | -- |
- )- |
-
529 | -- |
- )- |
-
530 | -- |
- },- |
-
531 | -! | -
- outlier_var_name = as.name(outlier_var),- |
-
532 | -! | -
- group_expr = if (isTRUE(split_outliers) && length(categorical_var) != 0) {- |
-
533 | -! | -
- substitute(dplyr::group_by(x), list(x = as.name(categorical_var)))- |
-
534 | -- |
- },- |
-
535 | -! | -
- ungroup_expr = if (isTRUE(split_outliers) && length(categorical_var) != 0) {- |
-
536 | -! | -
- substitute(dplyr::ungroup())- |
-
537 | -- |
- }- |
-
538 | -- |
- )- |
-
539 | -- |
- ) %>%- |
-
540 | -! | -
- remove_pipe_null()- |
-
541 | -- |
- )- |
-
542 | -- | - - | -
543 | -- |
- # ANL_OUTLIER_EXTENDED is the base table- |
-
544 | -! | -
- qenv <- teal.code::eval_code(- |
-
545 | -! | -
- qenv,- |
-
546 | -! | -
- substitute(- |
-
547 | -! | -
- expr = {- |
-
548 | -! | -
- ANL_OUTLIER_EXTENDED <- dplyr::left_join(- |
-
549 | -! | -
- ANL_OUTLIER,- |
-
550 | -! | -
- dplyr::select(- |
-
551 | -! | -
- dataname,- |
-
552 | -! | -
- dplyr::setdiff(names(dataname), dplyr::setdiff(names(ANL_OUTLIER), join_keys))- |
-
553 | -- |
- ),- |
-
554 | -! | -
- by = join_keys- |
-
555 | -- |
- )- |
-
556 | -- |
- },- |
-
557 | -! | -
- env = list(- |
-
558 | -! | -
- dataname = as.name(dataname_first),- |
-
559 | -! | -
- join_keys = as.character(teal.data::join_keys(data())[dataname_first, dataname_first])- |
-
560 | -- |
- )- |
-
561 | -- |
- )- |
-
562 | -- |
- )- |
-
563 | -- | - - | -
564 | -! | -
- if (length(categorical_var) > 0) {- |
-
565 | -! | -
- qenv <- teal.code::eval_code(- |
-
566 | -! | -
- qenv,- |
-
567 | -! | -
- substitute(- |
-
568 | -! | -
- expr = summary_table_pre <- ANL_OUTLIER %>%- |
-
569 | -! | -
- dplyr::filter(is_outlier_selected) %>%- |
-
570 | -! | -
- dplyr::select(outlier_var_name, categorical_var_name) %>%- |
-
571 | -! | -
- dplyr::group_by(categorical_var_name) %>%- |
-
572 | -! | -
- dplyr::summarise(n_outliers = dplyr::n()) %>%- |
-
573 | -! | -
- dplyr::right_join(- |
-
574 | -! | -
- ANL %>%- |
-
575 | -! | -
- dplyr::select(outlier_var_name, categorical_var_name) %>%- |
-
576 | -! | -
- dplyr::group_by(categorical_var_name) %>%- |
-
577 | -! | -
- dplyr::summarise(- |
-
578 | -! | -
- total_in_cat = dplyr::n(),- |
-
579 | -! | -
- n_na = sum(is.na(outlier_var_name) | is.na(categorical_var_name))- |
-
580 | -- |
- ),- |
-
581 | -! | -
- by = categorical_var- |
-
582 | -- |
- ) %>%- |
-
583 | -- |
- # This is important as there may be categorical variables with natural orderings, e.g. AGE.- |
-
584 | -- |
- # The plots should be displayed by default in increasing order in these situations.- |
-
585 | -- |
- # dplyr::arrange will sort integer, factor, and character data types in the expected way.- |
-
586 | -! | -
- dplyr::arrange(categorical_var_name) %>%- |
-
587 | -! | -
- dplyr::mutate(- |
-
588 | -! | -
- n_outliers = dplyr::if_else(is.na(n_outliers), 0, as.numeric(n_outliers)),- |
-
589 | -! | -
- display_str = dplyr::if_else(- |
-
590 | -! | -
- n_outliers > 0,- |
-
591 | -! | -
- sprintf("%d [%.02f%%]", n_outliers, 100 * n_outliers / total_in_cat),- |
-
592 | -! | -
- "0"- |
-
593 | -- |
- ),- |
-
594 | -! | -
- display_str_na = dplyr::if_else(- |
-
595 | -! | -
- n_na > 0,- |
-
596 | -! | -
- sprintf("%d [%.02f%%]", n_na, 100 * n_na / total_in_cat),- |
-
597 | -! | -
- "0"- |
-
598 | -- |
- ),- |
-
599 | -! | -
- order = seq_along(n_outliers)- |
-
600 | -- |
- ),- |
-
601 | -! | -
- env = list(- |
-
602 | -! | -
- categorical_var = categorical_var,- |
-
603 | -! | -
- categorical_var_name = as.name(categorical_var),- |
-
604 | -! | -
- outlier_var_name = as.name(outlier_var)- |
-
605 | -- |
- )- |
-
606 | -- |
- )- |
-
607 | -- |
- )- |
-
608 | -- |
- # now to handle when user chooses to order based on amount of outliers- |
-
609 | -! | -
- if (order_by_outlier) {- |
-
610 | -! | -
- qenv <- teal.code::eval_code(- |
-
611 | -! | -
- qenv,- |
-
612 | -! | -
- quote(- |
-
613 | -! | -
- summary_table_pre <- summary_table_pre %>%- |
-
614 | -! | -
- dplyr::arrange(desc(n_outliers / total_in_cat)) %>%- |
-
615 | -! | -
- dplyr::mutate(order = seq_len(nrow(summary_table_pre)))- |
-
616 | -- |
- )- |
-
617 | -- |
- )- |
-
618 | -- |
- }- |
-
619 | -- | - - | -
620 | -! | -
- qenv <- teal.code::eval_code(- |
-
621 | -! | -
- qenv,- |
-
622 | -! | -
- substitute(- |
-
623 | -! | -
- expr = {- |
-
624 | -- |
- # In order for geom_rug to work properly when reordering takes place inside facet_grid,- |
-
625 | -- |
- # all tables must have the column used for reording.- |
-
626 | -- |
- # In this case, the column used for reordering is `order`.- |
-
627 | -! | -
- ANL_OUTLIER <- dplyr::left_join(- |
-
628 | -! | -
- ANL_OUTLIER,- |
-
629 | -! | -
- summary_table_pre[, c("order", categorical_var)],- |
-
630 | -! | -
- by = categorical_var- |
-
631 | -- |
- )- |
-
632 | -- |
- # so that x axis of plot aligns with columns of summary table, from most outliers to least by percentage- |
-
633 | -! | -
- ANL <- ANL %>%- |
-
634 | -! | -
- dplyr::left_join(- |
-
635 | -! | -
- dplyr::select(summary_table_pre, categorical_var_name, order),- |
-
636 | -! | -
- by = categorical_var- |
-
637 | -- |
- ) %>%- |
-
638 | -! | -
- dplyr::arrange(order)- |
-
639 | -! | -
- summary_table <- summary_table_pre %>%- |
-
640 | -! | -
- dplyr::select(- |
-
641 | -! | -
- categorical_var_name,- |
-
642 | -! | -
- Outliers = display_str, Missings = display_str_na, Total = total_in_cat- |
-
643 | -- |
- ) %>%- |
-
644 | -! | -
- dplyr::mutate_all(as.character) %>%- |
-
645 | -! | -
- tidyr::pivot_longer(-categorical_var_name) %>%- |
-
646 | -! | -
- tidyr::pivot_wider(names_from = categorical_var, values_from = value) %>%- |
-
647 | -! | -
- tibble::column_to_rownames("name")- |
-
648 | -! | -
- summary_table- |
-
649 | -- |
- },- |
-
650 | -! | -
- env = list(- |
-
651 | -! | -
- categorical_var = categorical_var,- |
-
652 | -! | -
- categorical_var_name = as.name(categorical_var)- |
-
653 | -- |
- )- |
-
654 | -- |
- )- |
-
655 | -- |
- )- |
-
656 | -- |
- }- |
-
657 | -- | - - | -
658 | -! | -
- if (length(categorical_var) > 0 && nrow(qenv[["ANL_OUTLIER"]]) > 0) {- |
-
659 | -! | -
- shinyjs::show("order_by_outlier")- |
-
660 | -- |
- } else {- |
-
661 | -! | -
- shinyjs::hide("order_by_outlier")- |
-
662 | -- |
- }- |
-
663 | -- | - - | -
664 | -! | -
- qenv- |
-
665 | -- |
- })- |
-
666 | -- | - - | -
667 | -! | -
- output$summary_table <- DT::renderDataTable(- |
-
668 | -! | -
- expr = {- |
-
669 | -! | -
- if (iv_r()$is_valid()) {- |
-
670 | -! | -
- categorical_var <- as.vector(merged$anl_input_r()$columns_source$categorical_var)- |
-
671 | -! | -
- if (!is.null(categorical_var)) {- |
-
672 | -! | -
- DT::datatable(- |
-
673 | -! | -
- common_code_q()[["summary_table"]],- |
-
674 | -! | -
- options = list(- |
-
675 | -! | -
- dom = "t",- |
-
676 | -! | -
- autoWidth = TRUE,- |
-
677 | -! | -
- columnDefs = list(list(width = "200px", targets = "_all"))- |
-
678 | -- |
- )- |
-
679 | -- |
- )- |
-
680 | -- |
- }- |
-
681 | -- |
- }- |
-
682 | -- |
- }- |
-
683 | -- |
- )- |
-
684 | -- | - - | -
685 | -- |
- # boxplot/violinplot # nolint commented_code- |
-
686 | -! | -
- boxplot_q <- reactive({- |
-
687 | -! | -
- req(common_code_q())- |
-
688 | -! | -
- ANL <- common_code_q()[["ANL"]]- |
-
689 | -! | -
- ANL_OUTLIER <- common_code_q()[["ANL_OUTLIER"]]- |
-
690 | -- | - - | -
691 | -! | -
- outlier_var <- as.vector(merged$anl_input_r()$columns_source$outlier_var)- |
-
692 | -! | -
- categorical_var <- as.vector(merged$anl_input_r()$columns_source$categorical_var)- |
-
693 | -- | - - | -
694 | -- |
- # validation- |
-
695 | -! | -
- teal::validate_has_data(ANL, 1)- |
-
696 | -- | - - | -
697 | -- |
- # boxplot- |
-
698 | -! | -
- plot_call <- quote(ANL %>% ggplot())- |
-
699 | -- | - - | -
700 | -! | -
- plot_call <- if (input$boxplot_alts == "Box plot") {- |
-
701 | -! | -
- substitute(expr = plot_call + geom_boxplot(outlier.shape = NA), env = list(plot_call = plot_call))- |
-
702 | -! | -
- } else if (input$boxplot_alts == "Violin plot") {- |
-
703 | -! | -
- substitute(expr = plot_call + geom_violin(), env = list(plot_call = plot_call))- |
-
704 | -- |
- } else {- |
-
705 | -! | -
- NULL- |
-
706 | -- |
- }- |
-
707 | -- | - - | -
708 | -! | -
- plot_call <- if (identical(categorical_var, character(0)) || is.null(categorical_var)) {- |
-
709 | -! | -
- inner_call <- substitute(- |
-
710 | -! | -
- expr = plot_call +- |
-
711 | -! | -
- aes(x = "Entire dataset", y = outlier_var_name) +- |
-
712 | -! | -
- scale_x_discrete(),- |
-
713 | -! | -
- env = list(plot_call = plot_call, outlier_var_name = as.name(outlier_var))- |
-
714 | -- |
- )- |
-
715 | -! | -
- if (nrow(ANL_OUTLIER) > 0) {- |
-
716 | -! | -
- substitute(- |
-
717 | -! | -
- expr = inner_call + geom_point(- |
-
718 | -! | -
- data = ANL_OUTLIER,- |
-
719 | -! | -
- aes(x = "Entire dataset", y = outlier_var_name, color = is_outlier_selected)- |
-
720 | -- |
- ),- |
-
721 | -! | -
- env = list(inner_call = inner_call, outlier_var_name = as.name(outlier_var))- |
-
722 | -- |
- )- |
-
723 | -- |
- } else {- |
-
724 | -! | -
- inner_call- |
-
725 | -- |
- }- |
-
726 | -- |
- } else {- |
-
727 | -! | -
- substitute(- |
-
728 | -! | -
- expr = plot_call +- |
-
729 | -! | -
- aes(y = outlier_var_name, x = reorder(categorical_var_name, order)) +- |
-
730 | -! | -
- xlab(categorical_var) +- |
-
731 | -! | -
- scale_x_discrete() +- |
-
732 | -! | -
- geom_point(- |
-
733 | -! | -
- data = ANL_OUTLIER,- |
-
734 | -! | -
- aes(x = as.factor(categorical_var_name), y = outlier_var_name, color = is_outlier_selected)- |
-
735 | -- |
- ),- |
-
736 | -! | -
- env = list(- |
-
737 | -! | -
- plot_call = plot_call,- |
-
738 | -! | -
- outlier_var_name = as.name(outlier_var),- |
-
739 | -! | -
- categorical_var_name = as.name(categorical_var),- |
-
740 | -! | -
- categorical_var = categorical_var- |
-
741 | -- |
- )- |
-
742 | -- |
- )- |
-
743 | -- |
- }- |
-
744 | -- | - - | -
745 | -! | -
- dev_ggplot2_args <- teal.widgets::ggplot2_args(- |
-
746 | -! | -
- labs = list(color = "Is outlier?"),- |
-
747 | -! | -
- theme = list(legend.position = "top")- |
-
748 | -- |
- )- |
-
749 | -- | - - | -
750 | -! | -
- all_ggplot2_args <- teal.widgets::resolve_ggplot2_args(- |
-
751 | -! | -
- user_plot = ggplot2_args[["Boxplot"]],- |
-
752 | -! | -
- user_default = ggplot2_args$default,- |
-
753 | -! | -
- module_plot = dev_ggplot2_args- |
-
754 | -- |
- )- |
-
755 | -- | - - | -
756 | -! | -
- parsed_ggplot2_args <- teal.widgets::parse_ggplot2_args(- |
-
757 | -! | -
- all_ggplot2_args,- |
-
758 | -! | -
- ggtheme = input$ggtheme- |
-
759 | -- |
- )- |
-
760 | -- | - - | -
761 | -! | -
- teal.code::eval_code(- |
-
762 | -! | -
- common_code_q(),- |
-
763 | -! | -
- substitute(- |
-
764 | -! | -
- expr = g <- plot_call +- |
-
765 | -! | -
- scale_color_manual(values = c("TRUE" = "red", "FALSE" = "black")) +- |
-
766 | -! | -
- labs + ggthemes + themes,- |
-
767 | -! | -
- env = list(- |
-
768 | -! | -
- plot_call = plot_call,- |
-
769 | -! | -
- labs = parsed_ggplot2_args$labs,- |
-
770 | -! | -
- ggthemes = parsed_ggplot2_args$ggtheme,- |
-
771 | -! | -
- themes = parsed_ggplot2_args$theme- |
-
772 | -- |
- )- |
-
773 | -- |
- )- |
-
774 | -- |
- ) %>%- |
-
775 | -! | -
- teal.code::eval_code(quote(print(g)))- |
-
776 | -- |
- })- |
-
777 | -- | - - | -
778 | -- |
- # density plot- |
-
779 | -! | -
- density_plot_q <- reactive({- |
-
780 | -! | -
- ANL <- common_code_q()[["ANL"]]- |
-
781 | -! | -
- ANL_OUTLIER <- common_code_q()[["ANL_OUTLIER"]]- |
-
782 | -- | - - | -
783 | -! | -
- outlier_var <- as.vector(merged$anl_input_r()$columns_source$outlier_var)- |
-
784 | -! | -
- categorical_var <- as.vector(merged$anl_input_r()$columns_source$categorical_var)- |
-
785 | -- | - - | -
786 | -- |
- # validation- |
-
787 | -! | -
- teal::validate_has_data(ANL, 1)- |
-
788 | -- |
- # plot- |
-
789 | -! | -
- plot_call <- substitute(- |
-
790 | -! | -
- expr = ANL %>%- |
-
791 | -! | -
- ggplot(aes(x = outlier_var_name)) +- |
-
792 | -! | -
- geom_density() +- |
-
793 | -! | -
- geom_rug(data = ANL_OUTLIER, aes(x = outlier_var_name, color = is_outlier_selected)) +- |
-
794 | -! | -
- scale_color_manual(values = c("TRUE" = "red", "FALSE" = "black")),- |
-
795 | -! | -
- env = list(outlier_var_name = as.name(outlier_var))- |
-
796 | -- |
- )- |
-
797 | -- | - - | -
798 | -! | -
- plot_call <- if (identical(categorical_var, character(0)) || is.null(categorical_var)) {- |
-
799 | -! | -
- substitute(expr = plot_call, env = list(plot_call = plot_call))- |
-
800 | -- |
- } else {- |
-
801 | -! | -
- substitute(- |
-
802 | -! | -
- expr = plot_call + facet_grid(~ reorder(categorical_var_name, order)),- |
-
803 | -! | -
- env = list(plot_call = plot_call, categorical_var_name = as.name(categorical_var))- |
-
804 | -- |
- )- |
-
805 | -- |
- }- |
-
806 | -- | - - | -
807 | -! | -
- dev_ggplot2_args <- teal.widgets::ggplot2_args(- |
-
808 | -! | -
- labs = list(color = "Is outlier?"),- |
-
809 | -! | -
- theme = list(legend.position = "top")- |
-
810 | -- |
- )- |
-
811 | -- | - - | -
812 | -! | -
- all_ggplot2_args <- teal.widgets::resolve_ggplot2_args(- |
-
813 | -! | -
- user_plot = ggplot2_args[["Density Plot"]],- |
-
814 | -! | -
- user_default = ggplot2_args$default,- |
-
815 | -! | -
- module_plot = dev_ggplot2_args- |
-
816 | -- |
- )- |
-
817 | -- | - - | -
818 | -! | -
- parsed_ggplot2_args <- teal.widgets::parse_ggplot2_args(- |
-
819 | -! | -
- all_ggplot2_args,- |
-
820 | -! | -
- ggtheme = input$ggtheme- |
-
821 | -- |
- )- |
-
822 | -- | - - | -
823 | -! | -
- teal.code::eval_code(- |
-
824 | -! | -
- common_code_q(),- |
-
825 | -! | -
- substitute(- |
-
826 | -! | -
- expr = g <- plot_call + labs + ggthemes + themes,- |
-
827 | -! | -
- env = list(- |
-
828 | -! | -
- plot_call = plot_call,- |
-
829 | -! | -
- labs = parsed_ggplot2_args$labs,- |
-
830 | -! | -
- themes = parsed_ggplot2_args$theme,- |
-
831 | -! | -
- ggthemes = parsed_ggplot2_args$ggtheme- |
-
832 | -- |
- )- |
-
833 | -- |
- )- |
-
834 | -- |
- ) %>%- |
-
835 | -! | -
- teal.code::eval_code(quote(print(g)))- |
-
836 | -- |
- })- |
-
837 | -- | - - | -
838 | -- |
- # Cumulative distribution plot- |
-
839 | -! | -
- cumulative_plot_q <- reactive({- |
-
840 | -! | -
- ANL <- common_code_q()[["ANL"]]- |
-
841 | -! | -
- ANL_OUTLIER <- common_code_q()[["ANL_OUTLIER"]]- |
-
842 | -- | - - | -
843 | -! | -
- qenv <- common_code_q()- |
-
844 | -- | - - | -
845 | -! | -
- outlier_var <- as.vector(merged$anl_input_r()$columns_source$outlier_var)- |
-
846 | -! | -
- categorical_var <- as.vector(merged$anl_input_r()$columns_source$categorical_var)- |
-
847 | -- | - - | -
848 | -- |
- # validation- |
-
849 | -! | -
- teal::validate_has_data(ANL, 1)- |
-
850 | -- | - - | -
851 | -- |
- # plot- |
-
852 | -! | -
- plot_call <- substitute(- |
-
853 | -! | -
- expr = ANL %>% ggplot(aes(x = outlier_var_name)) +- |
-
854 | -! | -
- stat_ecdf(),- |
-
855 | -! | -
- env = list(outlier_var_name = as.name(outlier_var))- |
-
856 | -- |
- )- |
-
857 | -! | -
- if (length(categorical_var) == 0) {- |
-
858 | -! | -
- qenv <- teal.code::eval_code(- |
-
859 | -! | -
- qenv,- |
-
860 | -! | -
- substitute(- |
-
861 | -! | -
- expr = {- |
-
862 | -! | -
- ecdf_df <- ANL %>%- |
-
863 | -! | -
- dplyr::mutate(- |
-
864 | -! | -
- y = stats::ecdf(ANL[[outlier_var]])(ANL[[outlier_var]])- |
-
865 | -- |
- )- |
-
866 | -- | - - | -
867 | -! | -
- outlier_points <- dplyr::left_join(- |
-
868 | -! | -
- ecdf_df,- |
-
869 | -! | -
- ANL_OUTLIER,- |
-
870 | -! | -
- by = dplyr::setdiff(names(ecdf_df), "y")- |
-
871 | -- |
- ) %>%- |
-
872 | -! | -
- dplyr::filter(!is.na(is_outlier_selected))- |
-
873 | -- |
- },- |
-
874 | -! | -
- env = list(outlier_var = outlier_var)- |
-
875 | -- |
- )- |
-
876 | -- |
- )- |
-
877 | -- |
- } else {- |
-
878 | -! | -
- qenv <- teal.code::eval_code(- |
-
879 | -! | -
- qenv,- |
-
880 | -! | -
- substitute(- |
-
881 | -! | -
- expr = {- |
-
882 | -! | -
- all_categories <- lapply(- |
-
883 | -! | -
- unique(ANL[[categorical_var]]),- |
-
884 | -! | -
- function(x) {- |
-
885 | -! | -
- ANL <- ANL %>% dplyr::filter(get(categorical_var) == x)- |
-
886 | -! | -
- anl_outlier2 <- ANL_OUTLIER %>% dplyr::filter(get(categorical_var) == x)- |
-
887 | -! | -
- ecdf_df <- ANL %>%- |
-
888 | -! | -
- dplyr::mutate(y = stats::ecdf(ANL[[outlier_var]])(ANL[[outlier_var]]))- |
-
889 | -- | - - | -
890 | -! | -
- dplyr::left_join(- |
-
891 | -! | -
- ecdf_df,- |
-
892 | -! | -
- anl_outlier2,- |
-
893 | -! | -
- by = dplyr::setdiff(names(ecdf_df), "y")- |
-
894 | -- |
- ) %>%- |
-
895 | -! | -
- dplyr::filter(!is.na(is_outlier_selected))- |
-
896 | -- |
- }- |
-
897 | -- |
- )- |
-
898 | -! | -
- outlier_points <- do.call(rbind, all_categories)- |
-
899 | -- |
- },- |
-
900 | -! | -
- env = list(categorical_var = categorical_var, outlier_var = outlier_var)- |
-
901 | -- |
- )- |
-
902 | -- |
- )- |
-
903 | -! | -
- plot_call <- substitute(- |
-
904 | -! | -
- expr = plot_call + facet_grid(~ reorder(categorical_var_name, order)),- |
-
905 | -! | -
- env = list(plot_call = plot_call, categorical_var_name = as.name(categorical_var))- |
-
906 | -- |
- )- |
-
907 | -- |
- }- |
-
908 | -- | - - | -
909 | -! | -
- dev_ggplot2_args <- teal.widgets::ggplot2_args(- |
-
910 | -! | -
- labs = list(color = "Is outlier?"),- |
-
911 | -! | -
- theme = list(legend.position = "top")- |
-
912 | -- |
- )- |
-
913 | -- | - - | -
914 | -! | -
- all_ggplot2_args <- teal.widgets::resolve_ggplot2_args(- |
-
915 | -! | -
- user_plot = ggplot2_args[["Cumulative Distribution Plot"]],- |
-
916 | -! | -
- user_default = ggplot2_args$default,- |
-
917 | -! | -
- module_plot = dev_ggplot2_args- |
-
918 | -- |
- )- |
-
919 | -- | - - | -
920 | -! | -
- parsed_ggplot2_args <- teal.widgets::parse_ggplot2_args(- |
-
921 | -! | -
- all_ggplot2_args,- |
-
922 | -! | -
- ggtheme = input$ggtheme- |
-
923 | -- |
- )- |
-
924 | -- | - - | -
925 | -! | -
- teal.code::eval_code(- |
-
926 | -! | -
- qenv,- |
-
927 | -! | -
- substitute(- |
-
928 | -! | -
- expr = g <- plot_call +- |
-
929 | -! | -
- geom_point(data = outlier_points, aes(x = outlier_var_name, y = y, color = is_outlier_selected)) +- |
-
930 | -! | -
- scale_color_manual(values = c("TRUE" = "red", "FALSE" = "black")) +- |
-
931 | -! | -
- labs + ggthemes + themes,- |
-
932 | -! | -
- env = list(- |
-
933 | -! | -
- plot_call = plot_call,- |
-
934 | -! | -
- outlier_var_name = as.name(outlier_var),- |
-
935 | -! | -
- labs = parsed_ggplot2_args$labs,- |
-
936 | -! | -
- themes = parsed_ggplot2_args$theme,- |
-
937 | -! | -
- ggthemes = parsed_ggplot2_args$ggtheme- |
-
938 | -- |
- )- |
-
939 | -- |
- )- |
-
940 | -- |
- ) %>%- |
-
941 | -! | -
- teal.code::eval_code(quote(print(g)))- |
-
942 | -- |
- })- |
-
943 | -- | - - | -
944 | -! | -
- final_q <- reactive({- |
-
945 | -! | -
- req(input$tabs)- |
-
946 | -! | -
- tab_type <- input$tabs- |
-
947 | -! | -
- result_q <- if (tab_type == "Boxplot") {- |
-
948 | -! | -
- boxplot_q()- |
-
949 | -! | -
- } else if (tab_type == "Density Plot") {- |
-
950 | -! | -
- density_plot_q()- |
-
951 | -! | -
- } else if (tab_type == "Cumulative Distribution Plot") {- |
-
952 | -! | -
- cumulative_plot_q()- |
-
953 | -- |
- }- |
-
954 | -- |
- # used to display table when running show-r-code code- |
-
955 | -- |
- # added after the plots so that a change in selected columns doesn't affect- |
-
956 | -- |
- # brush selection.- |
-
957 | -! | -
- teal.code::eval_code(- |
-
958 | -! | -
- result_q,- |
-
959 | -! | -
- substitute(- |
-
960 | -! | -
- expr = {- |
-
961 | -! | -
- columns_index <- union(- |
-
962 | -! | -
- setdiff(names(ANL_OUTLIER), "is_outlier_selected"),- |
-
963 | -! | -
- table_columns- |
-
964 | -- |
- )- |
-
965 | -! | -
- ANL_OUTLIER_EXTENDED[ANL_OUTLIER_EXTENDED$is_outlier_selected, columns_index]- |
-
966 | -- |
- },- |
-
967 | -! | -
- env = list(- |
-
968 | -! | -
- table_columns = input$table_ui_columns- |
-
969 | -- |
- )- |
-
970 | -- |
- )- |
-
971 | -- |
- )- |
-
972 | -- |
- })- |
-
973 | -- | - - | -
974 | -- |
- # slider text- |
-
975 | -! | -
- output$ui_outlier_help <- renderUI({- |
-
976 | -! | -
- req(input$method)- |
-
977 | -! | -
- if (input$method == "IQR") {- |
-
978 | -! | -
- req(input$iqr_slider)- |
-
979 | -! | -
- tags$small(- |
-
980 | -! | -
- withMathJax(- |
-
981 | -! | -
- helpText(- |
-
982 | -! | -
- "Outlier data points (\\(x \\lt Q1 - ", input$iqr_slider, "\\times IQR\\) or \\(- |
-
983 | -! | -
- Q3 + ", input$iqr_slider, "\\times IQR \\lt x\\))- |
-
984 | -! | -
- are displayed in red on the plot and can be visualized in the table below."- |
-
985 | -- |
- ),- |
-
986 | -! | -
- if (input$split_outliers) {- |
-
987 | -! | -
- withMathJax(helpText("Note: Quantiles are calculated per group."))- |
-
988 | -- |
- }- |
-
989 | -- |
- )- |
-
990 | -- |
- )- |
-
991 | -! | -
- } else if (input$method == "Z-score") {- |
-
992 | -! | -
- req(input$zscore_slider)- |
-
993 | -! | -
- tags$small(- |
-
994 | -! | -
- withMathJax(- |
-
995 | -! | -
- helpText(- |
-
996 | -! | -
- "Outlier data points (\\(Zscore(x) < -", input$zscore_slider,- |
-
997 | -! | -
- "\\) or \\(", input$zscore_slider, "< Zscore(x) \\))- |
-
998 | -! | -
- are displayed in red on the plot and can be visualized in the table below."- |
-
999 | -- |
- ),- |
-
1000 | -! | -
- if (input$split_outliers) {- |
-
1001 | -! | -
- withMathJax(helpText(" Note: Z-scores are calculated per group."))- |
-
1002 | -- |
- }- |
-
1003 | -- |
- )- |
-
1004 | -- |
- )- |
-
1005 | -! | -
- } else if (input$method == "Percentile") {- |
-
1006 | -! | -
- req(input$percentile_slider)- |
-
1007 | -! | -
- tags$small(- |
-
1008 | -! | -
- withMathJax(- |
-
1009 | -! | -
- helpText(- |
-
1010 | -! | -
- "Outlier/extreme data points (\\( Percentile(x) <", input$percentile_slider,- |
-
1011 | -! | -
- "\\) or \\(", 1 - input$percentile_slider, " < Percentile(x) \\))- |
-
1012 | -! | -
- are displayed in red on the plot and can be visualized in the table below."- |
-
1013 | -- |
- ),- |
-
1014 | -! | -
- if (input$split_outliers) {- |
-
1015 | -! | -
- withMathJax(helpText("Note: Percentiles are calculated per group."))- |
-
1016 | -- |
- }- |
-
1017 | -- |
- )- |
-
1018 | -- |
- )- |
-
1019 | -- |
- }- |
-
1020 | -- |
- })- |
-
1021 | -- | - - | -
1022 | -! | -
- boxplot_r <- reactive({- |
-
1023 | -! | -
- teal::validate_inputs(iv_r())- |
-
1024 | -! | -
- boxplot_q()[["g"]]- |
-
1025 | -- |
- })- |
-
1026 | -! | -
- density_plot_r <- reactive({- |
-
1027 | -! | -
- teal::validate_inputs(iv_r())- |
-
1028 | -! | -
- density_plot_q()[["g"]]- |
-
1029 | -- |
- })- |
-
1030 | -! | -
- cumulative_plot_r <- reactive({- |
-
1031 | -! | -
- teal::validate_inputs(iv_r())- |
-
1032 | -! | -
- cumulative_plot_q()[["g"]]- |
-
1033 | -- |
- })- |
-
1034 | -- | - - | -
1035 | -! | -
- box_pws <- teal.widgets::plot_with_settings_srv(- |
-
1036 | -! | -
- id = "box_plot",- |
-
1037 | -! | -
- plot_r = boxplot_r,- |
-
1038 | -! | -
- height = plot_height,- |
-
1039 | -! | -
- width = plot_width,- |
-
1040 | -! | -
- brushing = TRUE- |
-
1041 | -- |
- )- |
-
1042 | -- | - - | -
1043 | -! | -
- density_pws <- teal.widgets::plot_with_settings_srv(- |
-
1044 | -! | -
- id = "density_plot",- |
-
1045 | -! | -
- plot_r = density_plot_r,- |
-
1046 | -! | -
- height = plot_height,- |
-
1047 | -! | -
- width = plot_width,- |
-
1048 | -! | -
- brushing = TRUE- |
-
1049 | -- |
- )- |
-
1050 | -- | - - | -
1051 | -! | -
- cum_density_pws <- teal.widgets::plot_with_settings_srv(- |
-
1052 | -! | -
- id = "cum_density_plot",- |
-
1053 | -! | -
- plot_r = cumulative_plot_r,- |
-
1054 | -! | -
- height = plot_height,- |
-
1055 | -! | -
- width = plot_width,- |
-
1056 | -! | -
- brushing = TRUE- |
-
1057 | -- |
- )- |
-
1058 | -- | - - | -
1059 | -! | -
- choices <- teal.transform::variable_choices(data()[[dataname_first]])- |
-
1060 | -- | - - | -
1061 | -! | -
- observeEvent(common_code_q(), {- |
-
1062 | -! | -
- ANL_OUTLIER <- common_code_q()[["ANL_OUTLIER"]]- |
-
1063 | -! | -
- teal.widgets::updateOptionalSelectInput(- |
-
1064 | -! | -
- session,- |
-
1065 | -! | -
- inputId = "table_ui_columns",- |
-
1066 | -! | -
- choices = dplyr::setdiff(choices, names(ANL_OUTLIER)),- |
-
1067 | -! | -
- selected = isolate(input$table_ui_columns)- |
-
1068 | -- |
- )- |
-
1069 | -- |
- })- |
-
1070 | -- | - - | -
1071 | -! | -
- output$table_ui <- DT::renderDataTable(- |
-
1072 | -! | -
- expr = {- |
-
1073 | -! | -
- tab <- input$tabs- |
-
1074 | -! | -
- req(tab) # tab is NULL upon app launch, hence will crash without this statement- |
-
1075 | -! | -
- shiny::req(iv_r()$is_valid()) # Same validation as output$table_ui_wrap- |
-
1076 | -! | -
- outlier_var <- as.vector(merged$anl_input_r()$columns_source$outlier_var)- |
-
1077 | -! | -
- categorical_var <- as.vector(merged$anl_input_r()$columns_source$categorical_var)- |
-
1078 | -- | - - | -
1079 | -! | -
- ANL_OUTLIER <- common_code_q()[["ANL_OUTLIER"]]- |
-
1080 | -! | -
- ANL_OUTLIER_EXTENDED <- common_code_q()[["ANL_OUTLIER_EXTENDED"]]- |
-
1081 | -! | -
- ANL <- common_code_q()[["ANL"]]- |
-
1082 | -- | - - | -
1083 | -! | -
- plot_brush <- if (tab == "Boxplot") {- |
-
1084 | -! | -
- boxplot_r()- |
-
1085 | -! | -
- box_pws$brush()- |
-
1086 | -! | -
- } else if (tab == "Density Plot") {- |
-
1087 | -! | -
- density_plot_r()- |
-
1088 | -! | -
- density_pws$brush()- |
-
1089 | -! | -
- } else if (tab == "Cumulative Distribution Plot") {- |
-
1090 | -! | -
- cumulative_plot_r()- |
-
1091 | -! | -
- cum_density_pws$brush()- |
-
1092 | -- |
- }- |
-
1093 | -- | - - | -
1094 | -- |
- # removing unused column ASAP- |
-
1095 | -! | -
- ANL_OUTLIER$order <- ANL$order <- NULL- |
-
1096 | -- | - - | -
1097 | -! | -
- display_table <- if (!is.null(plot_brush)) {- |
-
1098 | -! | -
- if (length(categorical_var) > 0) {- |
-
1099 | -- |
- # due to reordering, the x-axis label may be changed to something like "reorder(categorical_var, order)"- |
-
1100 | -! | -
- if (tab == "Boxplot") {- |
-
1101 | -! | -
- plot_brush$mapping$x <- categorical_var- |
-
1102 | -- |
- } else {- |
-
1103 | -- |
- # the other plots use facetting- |
-
1104 | -- |
- # so it is panelvar1 that gets relabelled to "reorder(categorical_var, order)"- |
-
1105 | -! | -
- plot_brush$mapping$panelvar1 <- categorical_var- |
-
1106 | -- |
- }- |
-
1107 | -- |
- } else {- |
-
1108 | -! | -
- if (tab == "Boxplot") {- |
-
1109 | -- |
- # in boxplot with no categorical variable, there is no column in ANL that would correspond to x-axis- |
-
1110 | -- |
- # so a column needs to be inserted with the value "Entire dataset" because that's the label used in plot- |
-
1111 | -! | -
- ANL[[plot_brush$mapping$x]] <- "Entire dataset"- |
-
1112 | -- |
- }- |
-
1113 | -- |
- }- |
-
1114 | -- | - - | -
1115 | -- |
- # in density and cumulative plots, ANL does not have a column corresponding to y-axis.- |
-
1116 | -- |
- # so they need to be computed and attached to ANL- |
-
1117 | -! | -
- if (tab == "Density Plot") {- |
-
1118 | -! | -
- plot_brush$mapping$y <- "density"- |
-
1119 | -! | -
- ANL$density <- plot_brush$ymin- |
-
1120 | -- |
- # either ymin or ymax will work- |
-
1121 | -! | -
- } else if (tab == "Cumulative Distribution Plot") {- |
-
1122 | -! | -
- plot_brush$mapping$y <- "cdf"- |
-
1123 | -! | -
- if (length(categorical_var) > 0) {- |
-
1124 | -! | -
- ANL <- ANL %>%- |
-
1125 | -! | -
- dplyr::group_by(!!as.name(plot_brush$mapping$panelvar1)) %>%- |
-
1126 | -! | -
- dplyr::mutate(cdf = stats::ecdf(!!as.name(outlier_var))(!!as.name(outlier_var)))- |
-
1127 | -- |
- } else {- |
-
1128 | -! | -
- ANL$cdf <- stats::ecdf(ANL[[outlier_var]])(ANL[[outlier_var]])- |
-
1129 | -- |
- }- |
-
1130 | -- |
- }- |
-
1131 | -- | - - | -
1132 | -! | -
- brushed_rows <- brushedPoints(ANL, plot_brush)- |
-
1133 | -! | -
- if (nrow(brushed_rows) > 0) {- |
-
1134 | -- |
- # now we need to remove extra column from ANL so that it will have the same columns as ANL_OUTLIER- |
-
1135 | -- |
- # so that dplyr::intersect will work- |
-
1136 | -! | -
- if (tab == "Density Plot") {- |
-
1137 | -! | -
- brushed_rows$density <- NULL- |
-
1138 | -! | -
- } else if (tab == "Cumulative Distribution Plot") {- |
-
1139 | -! | -
- brushed_rows$cdf <- NULL- |
-
1140 | -! | -
- } else if (tab == "Boxplot" && length(categorical_var) == 0) {- |
-
1141 | -! | -
- brushed_rows[[plot_brush$mapping$x]] <- NULL- |
-
1142 | -- |
- }- |
-
1143 | -- |
- # is_outlier_selected is part of ANL_OUTLIER so needed here- |
-
1144 | -! | -
- brushed_rows$is_outlier_selected <- TRUE- |
-
1145 | -! | -
- dplyr::intersect(ANL_OUTLIER, brushed_rows)- |
-
1146 | -- |
- } else {- |
-
1147 | -! | -
- ANL_OUTLIER[0, ]- |
-
1148 | -- |
- }- |
-
1149 | -- |
- } else {- |
-
1150 | -! | -
- ANL_OUTLIER[ANL_OUTLIER$is_outlier_selected, ]- |
-
1151 | -- |
- }- |
-
1152 | -- | - - | -
1153 | -! | -
- display_table$is_outlier_selected <- NULL- |
-
1154 | -- | - - | -
1155 | -- |
- # Extend the brushed ANL_OUTLIER with additional columns- |
-
1156 | -! | -
- dplyr::left_join(- |
-
1157 | -! | -
- display_table,- |
-
1158 | -! | -
- dplyr::select(ANL_OUTLIER_EXTENDED, -"is_outlier_selected"),- |
-
1159 | -! | -
- by = names(display_table)- |
-
1160 | -- |
- ) %>%- |
-
1161 | -! | -
- dplyr::select(union(names(display_table), input$table_ui_columns))- |
-
1162 | -- |
- },- |
-
1163 | -! | -
- options = list(- |
-
1164 | -! | -
- searching = FALSE, language = list(- |
-
1165 | -! | -
- zeroRecords = "The brushed area does not contain outlier observations for the currently defined threshold"- |
-
1166 | -- |
- ),- |
-
1167 | -! | -
- pageLength = input$table_ui_rows- |
-
1168 | -- |
- )- |
-
1169 | -- |
- )- |
-
1170 | -- | - - | -
1171 | -! | -
- output$total_outliers <- renderUI({- |
-
1172 | -! | -
- shiny::req(iv_r()$is_valid())- |
-
1173 | -! | -
- ANL <- merged$anl_q_r()[["ANL"]]- |
-
1174 | -! | -
- ANL_OUTLIER <- common_code_q()[["ANL_OUTLIER"]]- |
-
1175 | -! | -
- teal::validate_has_data(ANL, 1)- |
-
1176 | -! | -
- ANL_OUTLIER_SELECTED <- ANL_OUTLIER[ANL_OUTLIER$is_outlier_selected, ]- |
-
1177 | -! | -
- h5(- |
-
1178 | -! | -
- sprintf(- |
-
1179 | -! | -
- "%s %d / %d [%.02f%%]",- |
-
1180 | -! | -
- "Total number of outlier(s):",- |
-
1181 | -! | -
- nrow(ANL_OUTLIER_SELECTED),- |
-
1182 | -! | -
- nrow(ANL),- |
-
1183 | -! | -
- 100 * nrow(ANL_OUTLIER_SELECTED) / nrow(ANL)- |
-
1184 | -- |
- )- |
-
1185 | -- |
- )- |
-
1186 | -- |
- })- |
-
1187 | -- | - - | -
1188 | -! | -
- output$total_missing <- renderUI({- |
-
1189 | -! | -
- if (n_outlier_missing() > 0) {- |
-
1190 | -! | -
- ANL <- merged$anl_q_r()[["ANL"]]- |
-
1191 | -! | -
- helpText(- |
-
1192 | -! | -
- sprintf(- |
-
1193 | -! | -
- "%s %d / %d [%.02f%%]",- |
-
1194 | -! | -
- "Total number of row(s) with missing values:",- |
-
1195 | -! | -
- n_outlier_missing(),- |
-
1196 | -! | -
- nrow(ANL),- |
-
1197 | -! | -
- 100 * (n_outlier_missing()) / nrow(ANL)- |
-
1198 | -- |
- )- |
-
1199 | -- |
- )- |
-
1200 | -- |
- }- |
-
1201 | -- |
- })- |
-
1202 | -- | - - | -
1203 | -! | -
- output$table_ui_wrap <- renderUI({- |
-
1204 | -! | -
- shiny::req(iv_r()$is_valid())- |
-
1205 | -! | -
- tagList(- |
-
1206 | -! | -
- teal.widgets::optionalSelectInput(- |
-
1207 | -! | -
- inputId = session$ns("table_ui_columns"),- |
-
1208 | -! | -
- label = "Choose additional columns",- |
-
1209 | -! | -
- choices = NULL,- |
-
1210 | -! | -
- selected = NULL,- |
-
1211 | -! | -
- multiple = TRUE- |
-
1212 | -- |
- ),- |
-
1213 | -! | -
- h4("Outlier Table"),- |
-
1214 | -! | -
- teal.widgets::get_dt_rows(session$ns("table_ui"), session$ns("table_ui_rows"))- |
-
1215 | -- |
- )- |
-
1216 | -- |
- })- |
-
1217 | -- | - - | -
1218 | -! | -
- teal.widgets::verbatim_popup_srv(- |
-
1219 | -! | -
- id = "warning",- |
-
1220 | -! | -
- verbatim_content = reactive(teal.code::get_warnings(final_q())),- |
-
1221 | -! | -
- title = "Warning",- |
-
1222 | -! | -
- disabled = reactive(is.null(teal.code::get_warnings(final_q())))- |
-
1223 | -- |
- )- |
-
1224 | -- | - - | -
1225 | -! | -
- teal.widgets::verbatim_popup_srv(- |
-
1226 | -! | -
- id = "rcode",- |
-
1227 | -! | -
- verbatim_content = reactive(teal.code::get_code(final_q())),- |
-
1228 | -! | -
- title = "Show R Code for Outlier"- |
-
1229 | -- |
- )- |
-
1230 | -- | - - | -
1231 | -- |
- ### REPORTER- |
-
1232 | -! | -
- if (with_reporter) {- |
-
1233 | -! | -
- card_fun <- function(comment, label) {- |
-
1234 | -! | -
- tab_type <- input$tabs- |
-
1235 | -! | -
- card <- teal::report_card_template(- |
-
1236 | -! | -
- title = paste0("Outliers - ", tab_type),- |
-
1237 | -! | -
- label = label,- |
-
1238 | -! | -
- with_filter = with_filter,- |
-
1239 | -! | -
- filter_panel_api = filter_panel_api- |
-
1240 | -- |
- )- |
-
1241 | -! | -
- categorical_var <- as.vector(merged$anl_input_r()$columns_source$categorical_var)- |
-
1242 | -! | -
- if (length(categorical_var) > 0) {- |
-
1243 | -! | -
- summary_table <- common_code_q()[["summary_table"]]- |
-
1244 | -! | -
- card$append_text("Summary Table", "header3")- |
-
1245 | -! | -
- card$append_table(summary_table)- |
-
1246 | -- |
- }- |
-
1247 | -! | -
- card$append_text("Plot", "header3")- |
-
1248 | -! | -
- if (tab_type == "Boxplot") {- |
-
1249 | -! | -
- card$append_plot(boxplot_r(), dim = box_pws$dim())- |
-
1250 | -! | -
- } else if (tab_type == "Density Plot") {- |
-
1251 | -! | -
- card$append_plot(density_plot_r(), dim = density_pws$dim())- |
-
1252 | -! | -
- } else if (tab_type == "Cumulative Distribution Plot") {- |
-
1253 | -! | -
- card$append_plot(cumulative_plot_r(), dim = cum_density_pws$dim())- |
-
1254 | -- |
- }- |
-
1255 | -! | -
- if (!comment == "") {- |
-
1256 | -! | -
- card$append_text("Comment", "header3")- |
-
1257 | -! | -
- card$append_text(comment)- |
-
1258 | -- |
- }- |
-
1259 | -! | -
- card$append_src(teal.code::get_code(final_q()))- |
-
1260 | -! | -
- card- |
-
1261 | -- |
- }- |
-
1262 | -! | -
- teal.reporter::simple_reporter_srv("simple_reporter", reporter = reporter, card_fun = card_fun)- |
-
1263 | -- |
- }- |
-
1264 | -- |
- ###- |
-
1265 | -- |
- })- |
-
1266 | -- |
- }- |
-
1 | -- |
- #' `teal` module: File viewer- |
-
2 | -- |
- #'- |
-
3 | -- |
- #' The file viewer module provides a tool to view static files.- |
-
4 | -- |
- #' Supported formats include text formats, `PDF`, `PNG` `APNG`,- |
-
5 | -- |
- #' `JPEG` `SVG`, `WEBP`, `GIF` and `BMP`.- |
-
6 | -- |
- #'- |
-
7 | -- |
- #' @inheritParams teal::module- |
-
8 | -- |
- #' @inheritParams shared_params- |
-
9 | -- |
- #' @param input_path (`list`) of the input paths, optional. Each element can be:- |
-
10 | -- |
- #'- |
-
11 | -- |
- #' Paths can be specified as absolute paths or relative to the running directory of the application.- |
-
12 | -- |
- #' Default to the current working directory if not supplied.- |
-
13 | -- |
- #'- |
-
14 | -- |
- #' @inherit shared_params return- |
-
15 | -- |
- #'- |
-
16 | -- |
- #' @examples- |
-
17 | -- |
- #' data <- teal_data()- |
-
18 | -- |
- #' data <- within(data, {- |
-
19 | -- |
- #' data <- data.frame(1)- |
-
20 | -- |
- #' })- |
-
21 | -- |
- #' datanames(data) <- c("data")- |
-
22 | -- |
- #'- |
-
23 | -- |
- #' app <- init(- |
-
24 | -- |
- #' data = data,- |
-
25 | -- |
- #' modules = modules(- |
-
26 | -- |
- #' tm_file_viewer(- |
-
27 | -- |
- #' input_path = list(- |
-
28 | -- |
- #' folder = system.file("sample_files", package = "teal.modules.general"),- |
-
29 | -- |
- #' png = system.file("sample_files/sample_file.png", package = "teal.modules.general"),- |
-
30 | -- |
- #' txt = system.file("sample_files/sample_file.txt", package = "teal.modules.general"),- |
-
31 | -- |
- #' url = "https://fda.gov/files/drugs/published/Portable-Document-Format-Specifications.pdf"- |
-
32 | -- |
- #' )- |
-
33 | -- |
- #' )- |
-
34 | -- |
- #' )- |
-
35 | -- |
- #' )- |
-
36 | -- |
- #' if (interactive()) {- |
-
37 | -- |
- #' shinyApp(app$ui, app$server)- |
-
38 | -- |
- #' }- |
-
39 | -- |
- #'- |
-
40 | -- |
- #' @export- |
-
41 | -- |
- #'- |
-
42 | -- |
- tm_file_viewer <- function(label = "File Viewer Module",- |
-
43 | -- |
- input_path = list("Current Working Directory" = ".")) {- |
-
44 | -! | -
- logger::log_info("Initializing tm_file_viewer")- |
-
45 | -- | - - | -
46 | -- |
- # Normalize the parameters- |
-
47 | -! | -
- if (length(label) == 0 || identical(label, "")) label <- " "- |
-
48 | -! | -
- if (length(input_path) == 0 || identical(input_path, "")) input_path <- list()- |
-
49 | -- | - - | -
50 | -- |
- # Start of assertions- |
-
51 | -! | -
- checkmate::assert_string(label)- |
-
52 | -- | - - | -
53 | -! | -
- checkmate::assert(- |
-
54 | -! | -
- checkmate::check_list(input_path, types = "character", min.len = 0),- |
-
55 | -! | -
- checkmate::check_character(input_path, min.len = 1)- |
-
56 | -- |
- )- |
-
57 | -! | -
- if (length(input_path) > 0) {- |
-
58 | -! | -
- valid_url <- function(url_input, timeout = 2) {- |
-
59 | -! | -
- con <- try(url(url_input), silent = TRUE)- |
-
60 | -! | -
- check <- suppressWarnings(try(open.connection(con, open = "rt", timeout = timeout), silent = TRUE)[1])- |
-
61 | -! | -
- try(close.connection(con), silent = TRUE)- |
-
62 | -! | -
- is.null(check)- |
-
63 | -- |
- }- |
-
64 | -! | -
- idx <- vapply(input_path, function(x) file.exists(x) || valid_url(x), logical(1))- |
-
65 | -- | - - | -
66 | -! | -
- if (!all(idx)) {- |
-
67 | -! | -
- warning(- |
-
68 | -! | -
- paste0(- |
-
69 | -! | -
- "Non-existent file or url path. Please provide valid paths for:\n",- |
-
70 | -! | -
- paste0(input_path[!idx], collapse = "\n")- |
-
71 | -- |
- )- |
-
72 | -- |
- )- |
-
73 | -- |
- }- |
-
74 | -! | -
- input_path <- input_path[idx]- |
-
75 | -- |
- } else {- |
-
76 | -! | -
- warning(- |
-
77 | -! | -
- "No file or url paths were provided."- |
-
78 | -- |
- )- |
-
79 | -- |
- }- |
-
80 | -- |
- # End of assertions- |
-
81 | -- | - - | -
82 | -- |
- # Make UI args- |
-
83 | -! | -
- args <- as.list(environment())- |
-
84 | -- | - - | -
85 | -! | -
- module(- |
-
86 | -! | -
- label = label,- |
-
87 | -! | -
- server = srv_viewer,- |
-
88 | -! | -
- server_args = list(input_path = input_path),- |
-
89 | -! | -
- ui = ui_viewer,- |
-
90 | -! | -
- ui_args = args,- |
-
91 | -! | -
- datanames = NULL- |
-
92 | -- |
- )- |
-
93 | -- |
- }- |
-
94 | -- | - - | -
95 | -- |
- # UI function for the file viewer module- |
-
96 | -- |
- ui_viewer <- function(id, ...) {- |
-
97 | -! | -
- args <- list(...)- |
-
98 | -! | -
- ns <- NS(id)- |
-
99 | -- | - - | -
100 | -! | -
- shiny::tagList(- |
-
101 | -! | -
- include_css_files("custom"),- |
-
102 | -! | -
- teal.widgets::standard_layout(- |
-
103 | -! | -
- output = div(- |
-
104 | -! | -
- uiOutput(ns("output"))- |
-
105 | -- |
- ),- |
-
106 | -! | -
- encoding = div(- |
-
107 | -! | -
- class = "file_viewer_encoding",- |
-
108 | -! | -
- tags$label("Encodings", class = "text-primary"),- |
-
109 | -! | -
- shinyTree::shinyTree(- |
-
110 | -! | -
- ns("tree"),- |
-
111 | -! | -
- dragAndDrop = FALSE,- |
-
112 | -! | -
- sort = FALSE,- |
-
113 | -! | -
- wholerow = TRUE,- |
-
114 | -! | -
- theme = "proton",- |
-
115 | -! | -
- multiple = FALSE- |
-
116 | -- |
- )- |
-
117 | -- |
- )- |
-
118 | -- |
- )- |
-
119 | -- |
- )- |
-
120 | -- |
- }- |
-
121 | -- | - - | -
122 | -- |
- # Server function for the file viewer module- |
-
123 | -- |
- srv_viewer <- function(id, input_path) {- |
-
124 | -! | -
- moduleServer(id, function(input, output, session) {- |
-
125 | -! | -
- temp_dir <- tempfile()- |
-
126 | -! | -
- if (!dir.exists(temp_dir)) {- |
-
127 | -! | -
- dir.create(temp_dir, recursive = TRUE)- |
-
128 | -- |
- }- |
-
129 | -! | -
- addResourcePath(basename(temp_dir), temp_dir)- |
-
130 | -- | - - | -
131 | -! | -
- test_path_text <- function(selected_path, type) {- |
-
132 | -! | -
- out <- tryCatch(- |
-
133 | -! | -
- expr = {- |
-
134 | -! | -
- if (type != "url") {- |
-
135 | -! | -
- selected_path <- normalizePath(selected_path, winslash = "/")- |
-
136 | -- |
- }- |
-
137 | -! | -
- readLines(con = selected_path)- |
-
138 | -- |
- },- |
-
139 | -! | -
- error = function(cond) FALSE,- |
-
140 | -! | -
- warning = function(cond) {- |
-
141 | -! | -
- `if`(grepl("^incomplete final line found on", cond[[1]]), suppressWarnings(eval(cond[[2]])), FALSE)- |
-
142 | -- |
- }- |
-
143 | -- |
- )- |
-
144 | -- |
- }- |
-
145 | -- | - - | -
146 | -! | -
- handle_connection_type <- function(selected_path) {- |
-
147 | -! | -
- file_extension <- tools::file_ext(selected_path)- |
-
148 | -! | -
- file_class <- suppressWarnings(file(selected_path))- |
-
149 | -! | -
- close(file_class)- |
-
150 | -- | - - | -
151 | -! | -
- output_text <- test_path_text(selected_path, type = class(file_class)[1])- |
-
152 | -- | - - | -
153 | -! | -
- if (class(file_class)[1] == "url") {- |
-
154 | -! | -
- list(selected_path = selected_path, output_text = output_text)- |
-
155 | -- |
- } else {- |
-
156 | -! | -
- file.copy(normalizePath(selected_path, winslash = "/"), temp_dir)- |
-
157 | -! | -
- selected_path <- file.path(basename(temp_dir), basename(selected_path))- |
-
158 | -! | -
- list(selected_path = selected_path, output_text = output_text)- |
-
159 | -- |
- }- |
-
160 | -- |
- }- |
-
161 | -- | - - | -
162 | -! | -
- display_file <- function(selected_path) {- |
-
163 | -! | -
- con_type <- handle_connection_type(selected_path)- |
-
164 | -! | -
- file_extension <- tools::file_ext(selected_path)- |
-
165 | -! | -
- if (file_extension %in% c("png", "apng", "jpg", "jpeg", "svg", "gif", "webp", "bmp")) {- |
-
166 | -! | -
- tags$img(src = con_type$selected_path, alt = "file does not exist")- |
-
167 | -! | -
- } else if (file_extension == "pdf") {- |
-
168 | -! | -
- tags$embed(- |
-
169 | -! | -
- class = "embed_pdf",- |
-
170 | -! | -
- src = con_type$selected_path- |
-
171 | -- |
- )- |
-
172 | -! | -
- } else if (!isFALSE(con_type$output_text[1])) {- |
-
173 | -! | -
- tags$pre(paste0(con_type$output_text, collapse = "\n"))- |
-
174 | -- |
- } else {- |
-
175 | -! | -
- tags$p("Please select a supported format.")- |
-
176 | -- |
- }- |
-
177 | -- |
- }- |
-
178 | -- | - - | -
179 | -! | -
- tree_list <- function(file_or_dir) {- |
-
180 | -! | -
- nested_list <- lapply(file_or_dir, function(path) {- |
-
181 | -! | -
- file_class <- suppressWarnings(file(path))- |
-
182 | -! | -
- close(file_class)- |
-
183 | -! | -
- if (class(file_class)[[1]] != "url") {- |
-
184 | -! | -
- isdir <- file.info(path)$isdir- |
-
185 | -! | -
- if (!isdir) {- |
-
186 | -! | -
- structure(path, ancestry = path, sticon = "file")- |
-
187 | -- |
- } else {- |
-
188 | -! | -
- files <- list.files(path, full.names = TRUE, include.dirs = TRUE)- |
-
189 | -! | -
- out <- lapply(files, function(x) tree_list(x))- |
-
190 | -! | -
- out <- unlist(out, recursive = FALSE)- |
-
191 | -! | -
- if (length(files) > 0) names(out) <- basename(files)- |
-
192 | -! | -
- out- |
-
193 | -- |
- }- |
-
194 | -- |
- } else {- |
-
195 | -! | -
- structure(path, ancestry = path, sticon = "file")- |
-
196 | -- |
- }- |
-
197 | -- |
- })- |
-
198 | -- | - - | -
199 | -! | -
- missing_labels <- if (is.null(names(nested_list))) seq_along(nested_list) else which(names(nested_list) == "")- |
-
200 | -! | -
- names(nested_list)[missing_labels] <- file_or_dir[missing_labels]- |
-
201 | -! | -
- nested_list- |
-
202 | -- |
- }- |
-
203 | -- | - - | -
204 | -! | -
- output$tree <- shinyTree::renderTree({- |
-
205 | -! | -
- if (length(input_path) > 0) {- |
-
206 | -! | -
- tree_list(input_path)- |
-
207 | -- |
- } else {- |
-
208 | -! | -
- list("Empty Path" = NULL)- |
-
209 | -- |
- }- |
-
210 | -- |
- })- |
-
211 | -- | - - | -
212 | -! | -
- output$output <- renderUI({- |
-
213 | -! | -
- validate(- |
-
214 | -! | -
- need(- |
-
215 | -! | -
- length(shinyTree::get_selected(input$tree)) > 0,- |
-
216 | -! | -
- "Please select a file."- |
-
217 | -- |
- )- |
-
218 | -- |
- )- |
-
219 | -- | - - | -
220 | -! | -
- obj <- shinyTree::get_selected(input$tree, format = "names")[[1]]- |
-
221 | -! | -
- repo <- attr(obj, "ancestry")- |
-
222 | -! | -
- repo_collapsed <- if (length(repo) > 1) paste0(repo, collapse = "/") else repo- |
-
223 | -! | -
- is_not_named <- file.exists(file.path(c(repo_collapsed, obj[1])))[1]- |
-
224 | -- | - - | -
225 | -! | -
- if (is_not_named) {- |
-
226 | -! | -
- selected_path <- do.call("file.path", as.list(c(repo, obj[1])))- |
-
227 | -- |
- } else {- |
-
228 | -! | -
- if (length(repo) == 0) {- |
-
229 | -! | -
- selected_path <- do.call("file.path", as.list(attr(input$tree[[obj[1]]], "ancestry")))- |
-
230 | -- |
- } else {- |
-
231 | -! | -
- selected_path <- do.call("file.path", as.list(attr(input$tree[[repo]][[obj[1]]], "ancestry")))- |
-
232 | -- |
- }- |
-
233 | -- |
- }- |
-
234 | -- | - - | -
235 | -! | -
- validate(- |
-
236 | -! | -
- need(- |
-
237 | -! | -
- !isTRUE(file.info(selected_path)$isdir) && length(selected_path) > 0,- |
-
238 | -! | -
- "Please select a single file."- |
-
239 | -- |
- )- |
-
240 | -- |
- )- |
-
241 | -! | -
- display_file(selected_path)- |
-
242 | -- |
- })- |
-
243 | -- | - - | -
244 | -! | -
- onStop(function() {- |
-
245 | -! | -
- removeResourcePath(basename(temp_dir))- |
-
246 | -! | -
- unlink(temp_dir)- |
-
247 | -- |
- })- |
-
248 | -- |
- })- |
-
249 | -- |
- }- |
-
1 | -- |
- #' `teal` module: Cross-table- |
-
2 | -- |
- #'- |
-
3 | -- |
- #' Generates a simple cross-table of two variables from a dataset with custom- |
-
4 | -- |
- #' options for showing percentages and sub-totals.- |
-
5 | -- |
- #'- |
-
6 | -- |
- #' @inheritParams teal::module- |
-
7 | -- |
- #' @inheritParams shared_params- |
-
8 | -- |
- #' @param x (`data_extract_spec` or `list` of multiple `data_extract_spec`)- |
-
9 | -- |
- #' Object with all available choices with pre-selected option for variable X - row values.- |
-
10 | -- |
- #' In case of `data_extract_spec` use `select_spec(..., ordered = TRUE)` if table elements should be- |
-
11 | -- |
- #' rendered according to selection order.- |
-
12 | -- |
- #' @param y (`data_extract_spec` or `list` of multiple `data_extract_spec`)- |
-
13 | -- |
- #' Object with all available choices with pre-selected option for variable Y - column values.- |
-
14 | -- |
- #'- |
-
15 | -- |
- #' `data_extract_spec` must not allow multiple selection in this case.- |
-
16 | -- |
- #' @param show_percentage (`logical(1)`)- |
-
17 | -- |
- #' Indicates whether to show percentages (relevant only when `x` is a `factor`).- |
-
18 | -- |
- #' Defaults to `TRUE`.- |
-
19 | -- |
- #' @param show_total (`logical(1)`)- |
-
20 | -- |
- #' Indicates whether to show total column.- |
-
21 | -- |
- #' Defaults to `TRUE`.- |
-
22 | -- |
- #'- |
-
23 | -- |
- #' @note For more examples, please see the vignette "Using cross table" via- |
-
24 | -- |
- #' `vignette("using-cross-table", package = "teal.modules.general")`.- |
-
25 | -- |
- #'- |
-
26 | -- |
- #' @inherit shared_params return- |
-
27 | -- |
- #'- |
-
28 | -- |
- #' @examples- |
-
29 | -- |
- #' # general data example- |
-
30 | -- |
- #' library(teal.widgets)- |
-
31 | -- |
- #'- |
-
32 | -- |
- #' data <- teal_data()- |
-
33 | -- |
- #' data <- within(data, {- |
-
34 | -- |
- #' mtcars <- mtcars- |
-
35 | -- |
- #' for (v in c("cyl", "vs", "am", "gear")) {- |
-
36 | -- |
- #' mtcars[[v]] <- as.factor(mtcars[[v]])- |
-
37 | -- |
- #' }- |
-
38 | -- |
- #' mtcars[["primary_key"]] <- seq_len(nrow(mtcars))- |
-
39 | -- |
- #' })- |
-
40 | -- |
- #' datanames(data) <- "mtcars"- |
-
41 | -- |
- #' join_keys(data) <- join_keys(join_key("mtcars", "mtcars", "primary_key"))- |
-
42 | -- |
- #'- |
-
43 | -- |
- #' app <- init(- |
-
44 | -- |
- #' data = data,- |
-
45 | -- |
- #' modules = modules(- |
-
46 | -- |
- #' tm_t_crosstable(- |
-
47 | -- |
- #' label = "Cross Table",- |
-
48 | -- |
- #' x = data_extract_spec(- |
-
49 | -- |
- #' dataname = "mtcars",- |
-
50 | -- |
- #' select = select_spec(- |
-
51 | -- |
- #' label = "Select variable:",- |
-
52 | -- |
- #' choices = variable_choices(data[["mtcars"]], c("cyl", "vs", "am", "gear")),- |
-
53 | -- |
- #' selected = c("cyl", "gear"),- |
-
54 | -- |
- #' multiple = TRUE,- |
-
55 | -- |
- #' ordered = TRUE,- |
-
56 | -- |
- #' fixed = FALSE- |
-
57 | -- |
- #' )- |
-
58 | -- |
- #' ),- |
-
59 | -- |
- #' y = data_extract_spec(- |
-
60 | -- |
- #' dataname = "mtcars",- |
-
61 | -- |
- #' select = select_spec(- |
-
62 | -- |
- #' label = "Select variable:",- |
-
63 | -- |
- #' choices = variable_choices(data[["mtcars"]], c("cyl", "vs", "am", "gear")),- |
-
64 | -- |
- #' selected = "vs",- |
-
65 | -- |
- #' multiple = FALSE,- |
-
66 | -- |
- #' fixed = FALSE- |
-
67 | -- |
- #' )- |
-
68 | -- |
- #' ),- |
-
69 | -- |
- #' basic_table_args = basic_table_args(- |
-
70 | -- |
- #' subtitles = "Table generated by Crosstable Module"- |
-
71 | -- |
- #' )- |
-
72 | -- |
- #' )- |
-
73 | -- |
- #' )- |
-
74 | -- |
- #' )- |
-
75 | -- |
- #' if (interactive()) {- |
-
76 | -- |
- #' shinyApp(app$ui, app$server)- |
-
77 | -- |
- #' }- |
-
78 | -- |
- #'- |
-
79 | -- |
- #' # CDISC data example- |
-
80 | -- |
- #' library(teal.widgets)- |
-
81 | -- |
- #'- |
-
82 | -- |
- #' data <- teal_data()- |
-
83 | -- |
- #' data <- within(data, {- |
-
84 | -- |
- #' ADSL <- rADSL- |
-
85 | -- |
- #' })- |
-
86 | -- |
- #' datanames(data) <- "ADSL"- |
-
87 | -- |
- #' join_keys(data) <- default_cdisc_join_keys[datanames(data)]- |
-
88 | -- |
- #'- |
-
89 | -- |
- #' app <- init(- |
-
90 | -- |
- #' data = data,- |
-
91 | -- |
- #' modules = modules(- |
-
92 | -- |
- #' tm_t_crosstable(- |
-
93 | -- |
- #' label = "Cross Table",- |
-
94 | -- |
- #' x = data_extract_spec(- |
-
95 | -- |
- #' dataname = "ADSL",- |
-
96 | -- |
- #' select = select_spec(- |
-
97 | -- |
- #' label = "Select variable:",- |
-
98 | -- |
- #' choices = variable_choices(data[["ADSL"]], subset = function(data) {- |
-
99 | -- |
- #' idx <- !vapply(data, inherits, logical(1), c("Date", "POSIXct", "POSIXlt"))- |
-
100 | -- |
- #' return(names(data)[idx])- |
-
101 | -- |
- #' }),- |
-
102 | -- |
- #' selected = "COUNTRY",- |
-
103 | -- |
- #' multiple = TRUE,- |
-
104 | -- |
- #' ordered = TRUE,- |
-
105 | -- |
- #' fixed = FALSE- |
-
106 | -- |
- #' )- |
-
107 | -- |
- #' ),- |
-
108 | -- |
- #' y = data_extract_spec(- |
-
109 | -- |
- #' dataname = "ADSL",- |
-
110 | -- |
- #' select = select_spec(- |
-
111 | -- |
- #' label = "Select variable:",- |
-
112 | -- |
- #' choices = variable_choices(data[["ADSL"]], subset = function(data) {- |
-
113 | -- |
- #' idx <- vapply(data, is.factor, logical(1))- |
-
114 | -- |
- #' return(names(data)[idx])- |
-
115 | -- |
- #' }),- |
-
116 | -- |
- #' selected = "SEX",- |
-
117 | -- |
- #' multiple = FALSE,- |
-
118 | -- |
- #' fixed = FALSE- |
-
119 | -- |
- #' )- |
-
120 | -- |
- #' ),- |
-
121 | -- |
- #' basic_table_args = basic_table_args(- |
-
122 | -- |
- #' subtitles = "Table generated by Crosstable Module"- |
-
123 | -- |
- #' )- |
-
124 | -- |
- #' )- |
-
125 | -- |
- #' )- |
-
126 | -- |
- #' )- |
-
127 | -- |
- #' if (interactive()) {- |
-
128 | -- |
- #' shinyApp(app$ui, app$server)- |
-
129 | -- |
- #' }- |
-
130 | -- |
- #'- |
-
131 | -- |
- #' @export- |
-
132 | -- |
- #'- |
-
133 | -- |
- tm_t_crosstable <- function(label = "Cross Table",- |
-
134 | -- |
- x,- |
-
135 | -- |
- y,- |
-
136 | -- |
- show_percentage = TRUE,- |
-
137 | -- |
- show_total = TRUE,- |
-
138 | -- |
- pre_output = NULL,- |
-
139 | -- |
- post_output = NULL,- |
-
140 | -- |
- basic_table_args = teal.widgets::basic_table_args()) {- |
-
141 | -! | -
- logger::log_info("Initializing tm_t_crosstable")- |
-
142 | -- | - - | -
143 | -- |
- # Requires Suggested packages- |
-
144 | -! | -
- if (!requireNamespace("rtables", quietly = TRUE)) {- |
-
145 | -! | -
- stop("Cannot load rtables - please install the package or restart your session.")- |
-
146 | -- |
- }- |
-
147 | -- | - - | -
148 | -- |
- # Normalize the parameters- |
-
149 | -! | -
- if (inherits(x, "data_extract_spec")) x <- list(x)- |
-
150 | -! | -
- if (inherits(y, "data_extract_spec")) y <- list(y)- |
-
151 | -- | - - | -
152 | -- |
- # Start of assertions- |
-
153 | -! | -
- checkmate::assert_string(label)- |
-
154 | -! | -
- checkmate::assert_list(x, types = "data_extract_spec")- |
-
155 | -- | - - | -
156 | -! | -
- checkmate::assert_list(y, types = "data_extract_spec")- |
-
157 | -! | -
- assert_single_selection(y)- |
-
158 | -- | - - | -
159 | -! | -
- checkmate::assert_flag(show_percentage)- |
-
160 | -! | -
- checkmate::assert_flag(show_total)- |
-
161 | -! | -
- checkmate::assert_multi_class(pre_output, c("shiny.tag", "shiny.tag.list", "html"), null.ok = TRUE)- |
-
162 | -! | -
- checkmate::assert_multi_class(post_output, c("shiny.tag", "shiny.tag.list", "html"), null.ok = TRUE)- |
-
163 | -! | -
- checkmate::assert_class(basic_table_args, classes = "basic_table_args")- |
-
164 | -- |
- # End of assertions- |
-
165 | -- | - - | -
166 | -- |
- # Make UI args- |
-
167 | -! | -
- ui_args <- as.list(environment())- |
-
168 | -- | - - | -
169 | -! | -
- server_args <- list(- |
-
170 | -! | -
- label = label,- |
-
171 | -! | -
- x = x,- |
-
172 | -! | -
- y = y,- |
-
173 | -! | -
- basic_table_args = basic_table_args- |
-
174 | -- |
- )- |
-
175 | -- | - - | -
176 | -! | -
- module(- |
-
177 | -! | -
- label = label,- |
-
178 | -! | -
- server = srv_t_crosstable,- |
-
179 | -! | -
- ui = ui_t_crosstable,- |
-
180 | -! | -
- ui_args = ui_args,- |
-
181 | -! | -
- server_args = server_args,- |
-
182 | -! | -
- datanames = teal.transform::get_extract_datanames(list(x = x, y = y))- |
-
183 | -- |
- )- |
-
184 | -- |
- }- |
-
185 | -- | - - | -
186 | -- |
- # UI function for the cross-table module- |
-
187 | -- |
- ui_t_crosstable <- function(id, x, y, show_percentage, show_total, pre_output, post_output, ...) {- |
-
188 | -! | -
- ns <- NS(id)- |
-
189 | -! | -
- is_single_dataset <- teal.transform::is_single_dataset(x, y)- |
-
190 | -- | - - | -
191 | -! | -
- join_default_options <- c(- |
-
192 | -! | -
- "Full Join" = "dplyr::full_join",- |
-
193 | -! | -
- "Inner Join" = "dplyr::inner_join",- |
-
194 | -! | -
- "Left Join" = "dplyr::left_join",- |
-
195 | -! | -
- "Right Join" = "dplyr::right_join"- |
-
196 | -- |
- )- |
-
197 | -- | - - | -
198 | -! | -
- teal.widgets::standard_layout(- |
-
199 | -! | -
- output = teal.widgets::white_small_well(- |
-
200 | -! | -
- textOutput(ns("title")),- |
-
201 | -! | -
- teal.widgets::table_with_settings_ui(ns("table"))- |
-
202 | -- |
- ),- |
-
203 | -! | -
- encoding = div(- |
-
204 | -- |
- ### Reporter- |
-
205 | -! | -
- teal.reporter::simple_reporter_ui(ns("simple_reporter")),- |
-
206 | -- |
- ###- |
-
207 | -! | -
- tags$label("Encodings", class = "text-primary"),- |
-
208 | -! | -
- teal.transform::datanames_input(list(x, y)),- |
-
209 | -! | -
- teal.transform::data_extract_ui(ns("x"), label = "Row values", x, is_single_dataset = is_single_dataset),- |
-
210 | -! | -
- teal.transform::data_extract_ui(ns("y"), label = "Column values", y, is_single_dataset = is_single_dataset),- |
-
211 | -! | -
- teal.widgets::optionalSelectInput(- |
-
212 | -! | -
- ns("join_fun"),- |
-
213 | -! | -
- label = "Row to Column type of join",- |
-
214 | -! | -
- choices = join_default_options,- |
-
215 | -! | -
- selected = join_default_options[1],- |
-
216 | -! | -
- multiple = FALSE- |
-
217 | -- |
- ),- |
-
218 | -! | -
- tags$hr(),- |
-
219 | -! | -
- teal.widgets::panel_group(- |
-
220 | -! | -
- teal.widgets::panel_item(- |
-
221 | -! | -
- title = "Table settings",- |
-
222 | -! | -
- checkboxInput(ns("show_percentage"), "Show column percentage", value = show_percentage),- |
-
223 | -! | -
- checkboxInput(ns("show_total"), "Show total column", value = show_total)- |
-
224 | -- |
- )- |
-
225 | -- |
- )- |
-
226 | -- |
- ),- |
-
227 | -! | -
- forms = tagList(- |
-
228 | -! | -
- teal.widgets::verbatim_popup_ui(ns("warning"), "Show Warnings"),- |
-
229 | -! | -
- teal.widgets::verbatim_popup_ui(ns("rcode"), "Show R code")- |
-
230 | -- |
- ),- |
-
231 | -! | -
- pre_output = pre_output,- |
-
232 | -! | -
- post_output = post_output- |
-
233 | -- |
- )- |
-
234 | -- |
- }- |
-
235 | -- | - - | -
236 | -- |
- # Server function for the cross-table module- |
-
237 | -- |
- srv_t_crosstable <- function(id, data, reporter, filter_panel_api, label, x, y, basic_table_args) {- |
-
238 | -! | -
- with_reporter <- !missing(reporter) && inherits(reporter, "Reporter")- |
-
239 | -! | -
- with_filter <- !missing(filter_panel_api) && inherits(filter_panel_api, "FilterPanelAPI")- |
-
240 | -! | -
- checkmate::assert_class(data, "reactive")- |
-
241 | -! | -
- checkmate::assert_class(isolate(data()), "teal_data")- |
-
242 | -! | -
- moduleServer(id, function(input, output, session) {- |
-
243 | -! | -
- selector_list <- teal.transform::data_extract_multiple_srv(- |
-
244 | -! | -
- data_extract = list(x = x, y = y),- |
-
245 | -! | -
- datasets = data,- |
-
246 | -! | -
- select_validation_rule = list(- |
-
247 | -! | -
- x = shinyvalidate::sv_required("Please define column for row variable."),- |
-
248 | -! | -
- y = shinyvalidate::sv_required("Please define column for column variable.")- |
-
249 | -- |
- )- |
-
250 | -- |
- )- |
-
251 | -- | - - | -
252 | -! | -
- iv_r <- reactive({- |
-
253 | -! | -
- iv <- shinyvalidate::InputValidator$new()- |
-
254 | -! | -
- iv$add_rule("join_fun", function(value) {- |
-
255 | -! | -
- if (!identical(selector_list()$x()$dataname, selector_list()$y()$dataname)) {- |
-
256 | -! | -
- if (!shinyvalidate::input_provided(value)) {- |
-
257 | -! | -
- "Please select a joining function."- |
-
258 | -- |
- }- |
-
259 | -- |
- }- |
-
260 | -- |
- })- |
-
261 | -! | -
- teal.transform::compose_and_enable_validators(iv, selector_list)- |
-
262 | -- |
- })- |
-
263 | -- | - - | -
264 | -! | -
- observeEvent(- |
-
265 | -! | -
- eventExpr = {- |
-
266 | -! | -
- req(!is.null(selector_list()$x()) && !is.null(selector_list()$y()))- |
-
267 | -! | -
- list(selector_list()$x(), selector_list()$y())- |
-
268 | -- |
- },- |
-
269 | -! | -
- handlerExpr = {- |
-
270 | -! | -
- if (identical(selector_list()$x()$dataname, selector_list()$y()$dataname)) {- |
-
271 | -! | -
- shinyjs::hide("join_fun")- |
-
272 | -- |
- } else {- |
-
273 | -! | -
- shinyjs::show("join_fun")- |
-
274 | -- |
- }- |
-
275 | -- |
- }- |
-
276 | -- |
- )- |
-
277 | -- | - - | -
278 | -! | -
- merge_function <- reactive({- |
-
279 | -! | -
- if (is.null(input$join_fun)) {- |
-
280 | -! | -
- "dplyr::full_join"- |
-
281 | -- |
- } else {- |
-
282 | -! | -
- input$join_fun- |
-
283 | -- |
- }- |
-
284 | -- |
- })- |
-
285 | -- | - - | -
286 | -! | -
- anl_merged_input <- teal.transform::merge_expression_srv(- |
-
287 | -! | -
- datasets = data,- |
-
288 | -! | -
- selector_list = selector_list,- |
-
289 | -! | -
- merge_function = merge_function- |
-
290 | -- |
- )- |
-
291 | -- | - - | -
292 | -! | -
- anl_merged_q <- reactive({- |
-
293 | -! | -
- req(anl_merged_input())- |
-
294 | -! | -
- data() %>%- |
-
295 | -! | -
- teal.code::eval_code(as.expression(anl_merged_input()$expr))- |
-
296 | -- |
- })- |
-
297 | -- | - - | -
298 | -! | -
- merged <- list(- |
-
299 | -! | -
- anl_input_r = anl_merged_input,- |
-
300 | -! | -
- anl_q_r = anl_merged_q- |
-
301 | -- |
- )- |
-
302 | -- | - - | -
303 | -! | -
- output_q <- reactive({- |
-
304 | -! | -
- teal::validate_inputs(iv_r())- |
-
305 | -! | -
- ANL <- merged$anl_q_r()[["ANL"]]- |
-
306 | -- | - - | -
307 | -- |
- # As this is a summary- |
-
308 | -! | -
- x_name <- as.vector(merged$anl_input_r()$columns_source$x)- |
-
309 | -! | -
- y_name <- as.vector(merged$anl_input_r()$columns_source$y)- |
-
310 | -- | - - | -
311 | -! | -
- teal::validate_has_data(ANL, 3)- |
-
312 | -! | -
- teal::validate_has_data(ANL[, c(x_name, y_name)], 3, complete = TRUE, allow_inf = FALSE)- |
-
313 | -- | - - | -
314 | -! | -
- is_allowed_class <- function(x) is.numeric(x) || is.factor(x) || is.character(x) || is.logical(x)- |
-
315 | -! | -
- validate(need(- |
-
316 | -! | -
- all(vapply(ANL[x_name], is_allowed_class, logical(1))),- |
-
317 | -! | -
- "Selected row variable has an unsupported data type."- |
-
318 | -- |
- ))- |
-
319 | -! | -
- validate(need(- |
-
320 | -! | -
- is_allowed_class(ANL[[y_name]]),- |
-
321 | -! | -
- "Selected column variable has an unsupported data type."- |
-
322 | -- |
- ))- |
-
323 | -- | - - | -
324 | -! | -
- show_percentage <- input$show_percentage- |
-
325 | -! | -
- show_total <- input$show_total- |
-
326 | -- | - - | -
327 | -! | -
- plot_title <- paste(- |
-
328 | -! | -
- "Cross-Table of",- |
-
329 | -! | -
- paste0(varname_w_label(x_name, ANL), collapse = ", "),- |
-
330 | -! | -
- "(rows)", "vs.",- |
-
331 | -! | -
- varname_w_label(y_name, ANL),- |
-
332 | -! | -
- "(columns)"- |
-
333 | -- |
- )- |
-
334 | -- | - - | -
335 | -! | -
- labels_vec <- vapply(- |
-
336 | -! | -
- x_name,- |
-
337 | -! | -
- varname_w_label,- |
-
338 | -! | -
- character(1),- |
-
339 | -! | -
- ANL- |
-
340 | -- |
- )- |
-
341 | -- | - - | -
342 | -! | -
- teal.code::eval_code(- |
-
343 | -! | -
- merged$anl_q_r(),- |
-
344 | -! | -
- substitute(- |
-
345 | -! | -
- expr = {- |
-
346 | -! | -
- title <- plot_title- |
-
347 | -- |
- },- |
-
348 | -! | -
- env = list(plot_title = plot_title)- |
-
349 | -- |
- )- |
-
350 | -- |
- ) %>%- |
-
351 | -! | -
- teal.code::eval_code(- |
-
352 | -! | -
- substitute(- |
-
353 | -! | -
- expr = {- |
-
354 | -! | -
- lyt <- basic_tables %>%- |
-
355 | -! | -
- split_call %>% # styler: off- |
-
356 | -! | -
- rtables::add_colcounts() %>%- |
-
357 | -! | -
- tern::analyze_vars(- |
-
358 | -! | -
- vars = x_name,- |
-
359 | -! | -
- var_labels = labels_vec,- |
-
360 | -! | -
- na.rm = FALSE,- |
-
361 | -! | -
- denom = "N_col",- |
-
362 | -! | -
- .stats = c("mean_sd", "median", "range", count_value)- |
-
363 | -- |
- )- |
-
364 | -- |
- },- |
-
365 | -! | -
- env = list(- |
-
366 | -! | -
- basic_tables = teal.widgets::parse_basic_table_args(- |
-
367 | -! | -
- basic_table_args = teal.widgets::resolve_basic_table_args(basic_table_args)- |
-
368 | -- |
- ),- |
-
369 | -! | -
- split_call = if (show_total) {- |
-
370 | -! | -
- substitute(- |
-
371 | -! | -
- expr = rtables::split_cols_by(- |
-
372 | -! | -
- y_name,- |
-
373 | -! | -
- split_fun = rtables::add_overall_level(label = "Total", first = FALSE)- |
-
374 | -- |
- ),- |
-
375 | -! | -
- env = list(y_name = y_name)- |
-
376 | -- |
- )- |
-
377 | -- |
- } else {- |
-
378 | -! | -
- substitute(rtables::split_cols_by(y_name), env = list(y_name = y_name))- |
-
379 | -- |
- },- |
-
380 | -! | -
- x_name = x_name,- |
-
381 | -! | -
- labels_vec = labels_vec,- |
-
382 | -! | -
- count_value = ifelse(show_percentage, "count_fraction", "count")- |
-
383 | -- |
- )- |
-
384 | -- |
- )- |
-
385 | -- |
- ) %>%- |
-
386 | -! | -
- teal.code::eval_code(- |
-
387 | -! | -
- substitute(- |
-
388 | -! | -
- expr = {- |
-
389 | -! | -
- ANL <- tern::df_explicit_na(ANL)- |
-
390 | -! | -
- tbl <- rtables::build_table(lyt = lyt, df = ANL[order(ANL[[y_name]]), ])- |
-
391 | -! | -
- tbl- |
-
392 | -- |
- },- |
-
393 | -! | -
- env = list(y_name = y_name)- |
-
394 | -- |
- )- |
-
395 | -- |
- )- |
-
396 | -- |
- })- |
-
397 | -- | - - | -
398 | -! | -
- output$title <- renderText(output_q()[["title"]])- |
-
399 | -- | - - | -
400 | -! | -
- table_r <- reactive({- |
-
401 | -! | -
- shiny::req(iv_r()$is_valid())- |
-
402 | -! | -
- output_q()[["tbl"]]- |
-
403 | -- |
- })- |
-
404 | -- | - - | -
405 | -! | -
- teal.widgets::table_with_settings_srv(- |
-
406 | -! | -
- id = "table",- |
-
407 | -! | -
- table_r = table_r- |
-
408 | -- |
- )- |
-
409 | -- | - - | -
410 | -! | -
- teal.widgets::verbatim_popup_srv(- |
-
411 | -! | -
- id = "warning",- |
-
412 | -! | -
- verbatim_content = reactive(teal.code::get_warnings(output_q())),- |
-
413 | -! | -
- title = "Warning",- |
-
414 | -! | -
- disabled = reactive(is.null(teal.code::get_warnings(output_q())))- |
-
415 | -- |
- )- |
-
416 | -- | - - | -
417 | -! | -
- teal.widgets::verbatim_popup_srv(- |
-
418 | -! | -
- id = "rcode",- |
-
419 | -! | -
- verbatim_content = reactive(teal.code::get_code(output_q())),- |
-
420 | -! | -
- title = "Show R Code for Cross-Table"- |
-
421 | -- |
- )- |
-
422 | -- | - - | -
423 | -- |
- ### REPORTER- |
-
424 | -! | -
- if (with_reporter) {- |
-
425 | -! | -
- card_fun <- function(comment, label) {- |
-
426 | -! | -
- card <- teal::report_card_template(- |
-
427 | -! | -
- title = "Cross Table",- |
-
428 | -! | -
- label = label,- |
-
429 | -! | -
- with_filter = with_filter,- |
-
430 | -! | -
- filter_panel_api = filter_panel_api- |
-
431 | -- |
- )- |
-
432 | -! | -
- card$append_text("Table", "header3")- |
-
433 | -! | -
- card$append_table(table_r())- |
-
434 | -! | -
- if (!comment == "") {- |
-
435 | -! | -
- card$append_text("Comment", "header3")- |
-
436 | -! | -
- card$append_text(comment)- |
-
437 | -- |
- }- |
-
438 | -! | -
- card$append_src(teal.code::get_code(output_q()))- |
-
439 | -! | -
- card- |
-
440 | -- |
- }- |
-
441 | -! | -
- teal.reporter::simple_reporter_srv("simple_reporter", reporter = reporter, card_fun = card_fun)- |
-
442 | -- |
- }- |
-
443 | -- |
- ###- |
-
444 | -- |
- })- |
-
445 | -- |
- }- |
-
1 | -- |
- #' `teal` module: Scatterplot matrix- |
-
2 | -- |
- #'- |
-
3 | -- |
- #' Generates a scatterplot matrix from selected `variables` from datasets.- |
-
4 | -- |
- #' Each plot within the matrix represents the relationship between two variables,- |
-
5 | -- |
- #' providing the overview of correlations and distributions across selected data.- |
-
6 | -- |
- #'- |
-
7 | -- |
- #' @note For more examples, please see the vignette "Using scatterplot matrix" via- |
-
8 | -- |
- #' `vignette("using-scatterplot-matrix", package = "teal.modules.general")`.- |
-
9 | -- |
- #'- |
-
10 | -- |
- #' @inheritParams teal::module- |
-
11 | -- |
- #' @inheritParams tm_g_scatterplot- |
-
12 | -- |
- #' @inheritParams shared_params- |
-
13 | -- |
- #'- |
-
14 | -- |
- #' @param variables (`data_extract_spec` or `list` of multiple `data_extract_spec`)- |
-
15 | -- |
- #' Specifies plotting variables from an incoming dataset with filtering and selecting. In case of- |
-
16 | -- |
- #' `data_extract_spec` use `select_spec(..., ordered = TRUE)` if plot elements should be- |
-
17 | -- |
- #' rendered according to selection order.- |
-
18 | -- |
- #'- |
-
19 | -- |
- #' @inherit shared_params return- |
-
20 | -- |
- #'- |
-
21 | -- |
- #' @examples- |
-
22 | -- |
- #' # general data example- |
-
23 | -- |
- #' data <- teal_data()- |
-
24 | -- |
- #' data <- within(data, {- |
-
25 | -- |
- #' countries <- data.frame(- |
-
26 | -- |
- #' id = c("DE", "FR", "IT", "ES", "PT", "GR", "NL", "BE", "LU", "AT"),- |
-
27 | -- |
- #' government = factor(- |
-
28 | -- |
- #' c(2, 2, 2, 1, 2, 2, 1, 1, 1, 2),- |
-
29 | -- |
- #' labels = c("Monarchy", "Republic")- |
-
30 | -- |
- #' ),- |
-
31 | -- |
- #' language_family = factor(- |
-
32 | -- |
- #' c(1, 3, 3, 3, 3, 2, 1, 1, 3, 1),- |
-
33 | -- |
- #' labels = c("Germanic", "Hellenic", "Romance")- |
-
34 | -- |
- #' ),- |
-
35 | -- |
- #' population = c(83, 67, 60, 47, 10, 11, 17, 11, 0.6, 9),- |
-
36 | -- |
- #' area = c(357, 551, 301, 505, 92, 132, 41, 30, 2.6, 83),- |
-
37 | -- |
- #' gdp = c(3.4, 2.7, 2.1, 1.4, 0.3, 0.2, 0.7, 0.5, 0.1, 0.4),- |
-
38 | -- |
- #' debt = c(2.1, 2.3, 2.4, 2.6, 2.3, 2.4, 2.3, 2.4, 2.3, 2.4)- |
-
39 | -- |
- #' )- |
-
40 | -- |
- #' sales <- data.frame(- |
-
41 | -- |
- #' id = 1:50,- |
-
42 | -- |
- #' country_id = sample(- |
-
43 | -- |
- #' c("DE", "FR", "IT", "ES", "PT", "GR", "NL", "BE", "LU", "AT"),- |
-
44 | -- |
- #' size = 50,- |
-
45 | -- |
- #' replace = TRUE- |
-
46 | -- |
- #' ),- |
-
47 | -- |
- #' year = sort(sample(2010:2020, 50, replace = TRUE)),- |
-
48 | -- |
- #' venue = sample(c("small", "medium", "large", "online"), 50, replace = TRUE),- |
-
49 | -- |
- #' cancelled = sample(c(TRUE, FALSE), 50, replace = TRUE),- |
-
50 | -- |
- #' quantity = rnorm(50, 100, 20),- |
-
51 | -- |
- #' costs = rnorm(50, 80, 20),- |
-
52 | -- |
- #' profit = rnorm(50, 20, 10)- |
-
53 | -- |
- #' )- |
-
54 | -- |
- #' })- |
-
55 | -- |
- #' datanames(data) <- c("countries", "sales")- |
-
56 | -- |
- #' join_keys(data) <- join_keys(- |
-
57 | -- |
- #' join_key("countries", "countries", "id"),- |
-
58 | -- |
- #' join_key("sales", "sales", "id"),- |
-
59 | -- |
- #' join_key("countries", "sales", c("id" = "country_id"))- |
-
60 | -- |
- #' )- |
-
61 | -- |
- #'- |
-
62 | -- |
- #' app <- init(- |
-
63 | -- |
- #' data = data,- |
-
64 | -- |
- #' modules = modules(- |
-
65 | -- |
- #' tm_g_scatterplotmatrix(- |
-
66 | -- |
- #' label = "Scatterplot matrix",- |
-
67 | -- |
- #' variables = list(- |
-
68 | -- |
- #' data_extract_spec(- |
-
69 | -- |
- #' dataname = "countries",- |
-
70 | -- |
- #' select = select_spec(- |
-
71 | -- |
- #' label = "Select variables:",- |
-
72 | -- |
- #' choices = variable_choices(data[["countries"]]),- |
-
73 | -- |
- #' selected = c("area", "gdp", "debt"),- |
-
74 | -- |
- #' multiple = TRUE,- |
-
75 | -- |
- #' ordered = TRUE,- |
-
76 | -- |
- #' fixed = FALSE- |
-
77 | -- |
- #' )- |
-
78 | -- |
- #' ),- |
-
79 | -- |
- #' data_extract_spec(- |
-
80 | -- |
- #' dataname = "sales",- |
-
81 | -- |
- #' filter = filter_spec(- |
-
82 | -- |
- #' label = "Select variable:",- |
-
83 | -- |
- #' vars = "country_id",- |
-
84 | -- |
- #' choices = value_choices(data[["sales"]], "country_id"),- |
-
85 | -- |
- #' selected = c("DE", "FR", "IT", "ES", "PT", "GR", "NL", "BE", "LU", "AT"),- |
-
86 | -- |
- #' multiple = TRUE- |
-
87 | -- |
- #' ),- |
-
88 | -- |
- #' select = select_spec(- |
-
89 | -- |
- #' label = "Select variables:",- |
-
90 | -- |
- #' choices = variable_choices(data[["sales"]], c("quantity", "costs", "profit")),- |
-
91 | -- |
- #' selected = c("quantity", "costs", "profit"),- |
-
92 | -- |
- #' multiple = TRUE,- |
-
93 | -- |
- #' ordered = TRUE,- |
-
94 | -- |
- #' fixed = FALSE- |
-
95 | -- |
- #' )- |
-
96 | -- |
- #' )- |
-
97 | -- |
- #' )- |
-
98 | -- |
- #' )- |
-
99 | -- |
- #' )- |
-
100 | -- |
- #' )- |
-
101 | -- |
- #' if (interactive()) {- |
-
102 | -- |
- #' shinyApp(app$ui, app$server)- |
-
103 | -- |
- #' }- |
-
104 | -- |
- #'- |
-
105 | -- |
- #' # CDISC data example- |
-
106 | -- |
- #' data <- teal_data()- |
-
107 | -- |
- #' data <- within(data, {- |
-
108 | -- |
- #' ADSL <- rADSL- |
-
109 | -- |
- #' ADRS <- rADRS- |
-
110 | -- |
- #' })- |
-
111 | -- |
- #' datanames(data) <- c("ADSL", "ADRS")- |
-
112 | -- |
- #' join_keys(data) <- default_cdisc_join_keys[datanames(data)]- |
-
113 | -- |
- #'- |
-
114 | -- |
- #' app <- init(- |
-
115 | -- |
- #' data = data,- |
-
116 | -- |
- #' modules = modules(- |
-
117 | -- |
- #' tm_g_scatterplotmatrix(- |
-
118 | -- |
- #' label = "Scatterplot matrix",- |
-
119 | -- |
- #' variables = list(- |
-
120 | -- |
- #' data_extract_spec(- |
-
121 | -- |
- #' dataname = "ADSL",- |
-
122 | -- |
- #' select = select_spec(- |
-
123 | -- |
- #' label = "Select variables:",- |
-
124 | -- |
- #' choices = variable_choices(data[["ADSL"]]),- |
-
125 | -- |
- #' selected = c("AGE", "RACE", "SEX"),- |
-
126 | -- |
- #' multiple = TRUE,- |
-
127 | -- |
- #' ordered = TRUE,- |
-
128 | -- |
- #' fixed = FALSE- |
-
129 | -- |
- #' )- |
-
130 | -- |
- #' ),- |
-
131 | -- |
- #' data_extract_spec(- |
-
132 | -- |
- #' dataname = "ADRS",- |
-
133 | -- |
- #' filter = filter_spec(- |
-
134 | -- |
- #' label = "Select endpoints:",- |
-
135 | -- |
- #' vars = c("PARAMCD", "AVISIT"),- |
-
136 | -- |
- #' choices = value_choices(data[["ADRS"]], c("PARAMCD", "AVISIT"), c("PARAM", "AVISIT")),- |
-
137 | -- |
- #' selected = "INVET - END OF INDUCTION",- |
-
138 | -- |
- #' multiple = TRUE- |
-
139 | -- |
- #' ),- |
-
140 | -- |
- #' select = select_spec(- |
-
141 | -- |
- #' label = "Select variables:",- |
-
142 | -- |
- #' choices = variable_choices(data[["ADRS"]]),- |
-
143 | -- |
- #' selected = c("AGE", "AVAL", "ADY"),- |
-
144 | -- |
- #' multiple = TRUE,- |
-
145 | -- |
- #' ordered = TRUE,- |
-
146 | -- |
- #' fixed = FALSE- |
-
147 | -- |
- #' )- |
-
148 | -- |
- #' )- |
-
149 | -- |
- #' )- |
-
150 | -- |
- #' )- |
-
151 | -- |
- #' )- |
-
152 | -- |
- #' )- |
-
153 | -- |
- #' if (interactive()) {- |
-
154 | -- |
- #' shinyApp(app$ui, app$server)- |
-
155 | -- |
- #' }- |
-
156 | -- |
- #'- |
-
157 | -- |
- #' @export- |
-
158 | -- |
- #'- |
-
159 | -- |
- tm_g_scatterplotmatrix <- function(label = "Scatterplot Matrix",- |
-
160 | -- |
- variables,- |
-
161 | -- |
- plot_height = c(600, 200, 2000),- |
-
162 | -- |
- plot_width = NULL,- |
-
163 | -- |
- pre_output = NULL,- |
-
164 | -- |
- post_output = NULL) {- |
-
165 | -! | -
- logger::log_info("Initializing tm_g_scatterplotmatrix")- |
-
166 | -- | - - | -
167 | -- |
- # Requires Suggested packages- |
-
168 | -! | -
- if (!requireNamespace("lattice", quietly = TRUE)) {- |
-
169 | -! | -
- stop("Cannot load lattice - please install the package or restart your session.")- |
-
170 | -- |
- }- |
-
171 | -- | - - | -
172 | -- |
- # Normalize the parameters- |
-
173 | -! | -
- if (inherits(variables, "data_extract_spec")) variables <- list(variables)- |
-
174 | -- | - - | -
175 | -- |
- # Start of assertions- |
-
176 | -! | -
- checkmate::assert_string(label)- |
-
177 | -! | -
- checkmate::assert_list(variables, types = "data_extract_spec")- |
-
178 | -- | - - | -
179 | -! | -
- checkmate::assert_numeric(plot_height, len = 3, any.missing = FALSE, finite = TRUE)- |
-
180 | -! | -
- checkmate::assert_numeric(plot_height[1], lower = plot_height[2], upper = plot_height[3], .var.name = "plot_height")- |
-
181 | -! | -
- checkmate::assert_numeric(plot_width, len = 3, any.missing = FALSE, null.ok = TRUE, finite = TRUE)- |
-
182 | -! | -
- checkmate::assert_numeric(- |
-
183 | -! | -
- plot_width[1],- |
-
184 | -! | -
- lower = plot_width[2], upper = plot_width[3], null.ok = TRUE, .var.name = "plot_width"- |
-
185 | -- |
- )- |
-
186 | -- | - - | -
187 | -! | -
- checkmate::assert_multi_class(pre_output, c("shiny.tag", "shiny.tag.list", "html"), null.ok = TRUE)- |
-
188 | -! | -
- checkmate::assert_multi_class(post_output, c("shiny.tag", "shiny.tag.list", "html"), null.ok = TRUE)- |
-
189 | -- |
- # End of assertions- |
-
190 | -- | - - | -
191 | -- |
- # Make UI args- |
-
192 | -! | -
- args <- as.list(environment())- |
-
193 | -- | - - | -
194 | -! | -
- module(- |
-
195 | -! | -
- label = label,- |
-
196 | -! | -
- server = srv_g_scatterplotmatrix,- |
-
197 | -! | -
- ui = ui_g_scatterplotmatrix,- |
-
198 | -! | -
- ui_args = args,- |
-
199 | -! | -
- server_args = list(variables = variables, plot_height = plot_height, plot_width = plot_width),- |
-
200 | -! | -
- datanames = teal.transform::get_extract_datanames(variables)- |
-
201 | -- |
- )- |
-
202 | -- |
- }- |
-
203 | -- | - - | -
204 | -- |
- # UI function for the scatterplot matrix module- |
-
205 | -- |
- ui_g_scatterplotmatrix <- function(id, ...) {- |
-
206 | -! | -
- args <- list(...)- |
-
207 | -! | -
- is_single_dataset_value <- teal.transform::is_single_dataset(args$variables)- |
-
208 | -! | -
- ns <- NS(id)- |
-
209 | -! | -
- teal.widgets::standard_layout(- |
-
210 | -! | -
- output = teal.widgets::white_small_well(- |
-
211 | -! | -
- textOutput(ns("message")),- |
-
212 | -! | -
- br(),- |
-
213 | -! | -
- teal.widgets::plot_with_settings_ui(id = ns("myplot"))- |
-
214 | -- |
- ),- |
-
215 | -! | -
- encoding = div(- |
-
216 | -- |
- ### Reporter- |
-
217 | -! | -
- teal.reporter::simple_reporter_ui(ns("simple_reporter")),- |
-
218 | -- |
- ###- |
-
219 | -! | -
- tags$label("Encodings", class = "text-primary"),- |
-
220 | -! | -
- teal.transform::datanames_input(args$variables),- |
-
221 | -! | -
- teal.transform::data_extract_ui(- |
-
222 | -! | -
- id = ns("variables"),- |
-
223 | -! | -
- label = "Variables",- |
-
224 | -! | -
- data_extract_spec = args$variables,- |
-
225 | -! | -
- is_single_dataset = is_single_dataset_value- |
-
226 | -- |
- ),- |
-
227 | -! | -
- hr(),- |
-
228 | -! | -
- teal.widgets::panel_group(- |
-
229 | -! | -
- teal.widgets::panel_item(- |
-
230 | -! | -
- title = "Plot settings",- |
-
231 | -! | -
- sliderInput(- |
-
232 | -! | -
- ns("alpha"), "Opacity:",- |
-
233 | -! | -
- min = 0, max = 1,- |
-
234 | -! | -
- step = .05, value = .5, ticks = FALSE- |
-
235 | -- |
- ),- |
-
236 | -! | -
- sliderInput(- |
-
237 | -! | -
- ns("cex"), "Points size:",- |
-
238 | -! | -
- min = 0.2, max = 3,- |
-
239 | -! | -
- step = .05, value = .65, ticks = FALSE- |
-
240 | -- |
- ),- |
-
241 | -! | -
- checkboxInput(ns("cor"), "Add Correlation", value = FALSE),- |
-
242 | -! | -
- radioButtons(- |
-
243 | -! | -
- ns("cor_method"), "Select Correlation Method",- |
-
244 | -! | -
- choiceNames = c("Pearson", "Kendall", "Spearman"),- |
-
245 | -! | -
- choiceValues = c("pearson", "kendall", "spearman"),- |
-
246 | -! | -
- inline = TRUE- |
-
247 | -- |
- ),- |
-
248 | -! | -
- checkboxInput(ns("cor_na_omit"), "Omit Missing Values", value = TRUE)- |
-
249 | -- |
- )- |
-
250 | -- |
- )- |
-
251 | -- |
- ),- |
-
252 | -! | -
- forms = tagList(- |
-
253 | -! | -
- teal.widgets::verbatim_popup_ui(ns("warning"), "Show Warnings"),- |
-
254 | -! | -
- teal.widgets::verbatim_popup_ui(ns("rcode"), "Show R code")- |
-
255 | -- |
- ),- |
-
256 | -! | -
- pre_output = args$pre_output,- |
-
257 | -! | -
- post_output = args$post_output- |
-
258 | -- |
- )- |
-
259 | -- |
- }- |
-
260 | -- | - - | -
261 | -- |
- # Server function for the scatterplot matrix module- |
-
262 | -- |
- srv_g_scatterplotmatrix <- function(id, data, reporter, filter_panel_api, variables, plot_height, plot_width) {- |
-
263 | -! | -
- with_reporter <- !missing(reporter) && inherits(reporter, "Reporter")- |
-
264 | -! | -
- with_filter <- !missing(filter_panel_api) && inherits(filter_panel_api, "FilterPanelAPI")- |
-
265 | -! | -
- checkmate::assert_class(data, "reactive")- |
-
266 | -! | -
- checkmate::assert_class(isolate(data()), "teal_data")- |
-
267 | -! | -
- moduleServer(id, function(input, output, session) {- |
-
268 | -! | -
- selector_list <- teal.transform::data_extract_multiple_srv(- |
-
269 | -! | -
- data_extract = list(variables = variables),- |
-
270 | -! | -
- datasets = data,- |
-
271 | -! | -
- select_validation_rule = list(- |
-
272 | -! | -
- variables = ~ if (length(.) <= 1) "Please select at least 2 columns."- |
-
273 | -- |
- )- |
-
274 | -- |
- )- |
-
275 | -- | - - | -
276 | -! | -
- iv_r <- reactive({- |
-
277 | -! | -
- iv <- shinyvalidate::InputValidator$new()- |
-
278 | -! | -
- teal.transform::compose_and_enable_validators(iv, selector_list)- |
-
279 | -- |
- })- |
-
280 | -- | - - | -
281 | -! | -
- anl_merged_input <- teal.transform::merge_expression_srv(- |
-
282 | -! | -
- datasets = data,- |
-
283 | -! | -
- selector_list = selector_list- |
-
284 | -- |
- )- |
-
285 | -- | - - | -
286 | -! | -
- anl_merged_q <- reactive({- |
-
287 | -! | -
- req(anl_merged_input())- |
-
288 | -! | -
- data() %>%- |
-
289 | -! | -
- teal.code::eval_code(as.expression(anl_merged_input()$expr))- |
-
290 | -- |
- })- |
-
291 | -- | - - | -
292 | -! | -
- merged <- list(- |
-
293 | -! | -
- anl_input_r = anl_merged_input,- |
-
294 | -! | -
- anl_q_r = anl_merged_q- |
-
295 | -- |
- )- |
-
296 | -- | - - | -
297 | -- |
- # plot- |
-
298 | -! | -
- output_q <- reactive({- |
-
299 | -! | -
- teal::validate_inputs(iv_r())- |
-
300 | -- | - - | -
301 | -! | -
- qenv <- merged$anl_q_r()- |
-
302 | -! | -
- ANL <- qenv[["ANL"]]- |
-
303 | -- | - - | -
304 | -! | -
- cols_names <- merged$anl_input_r()$columns_source$variables- |
-
305 | -! | -
- alpha <- input$alpha- |
-
306 | -! | -
- cex <- input$cex- |
-
307 | -! | -
- add_cor <- input$cor- |
-
308 | -! | -
- cor_method <- input$cor_method- |
-
309 | -! | -
- cor_na_omit <- input$cor_na_omit- |
-
310 | -- | - - | -
311 | -! | -
- cor_na_action <- if (isTruthy(cor_na_omit)) {- |
-
312 | -! | -
- "na.omit"- |
-
313 | -- |
- } else {- |
-
314 | -! | -
- "na.fail"- |
-
315 | -- |
- }- |
-
316 | -- | - - | -
317 | -! | -
- teal::validate_has_data(ANL, 10)- |
-
318 | -! | -
- teal::validate_has_data(ANL[, cols_names, drop = FALSE], 10, complete = TRUE, allow_inf = FALSE)- |
-
319 | -- | - - | -
320 | -- |
- # get labels and proper variable names- |
-
321 | -! | -
- varnames <- varname_w_label(cols_names, ANL, wrap_width = 20)- |
-
322 | -- | - - | -
323 | -- |
- # check character columns. If any, then those are converted to factors- |
-
324 | -! | -
- check_char <- vapply(ANL[, cols_names], is.character, logical(1))- |
-
325 | -! | -
- if (any(check_char)) {- |
-
326 | -! | -
- qenv <- teal.code::eval_code(- |
-
327 | -! | -
- qenv,- |
-
328 | -! | -
- substitute(- |
-
329 | -! | -
- expr = ANL <- ANL[, cols_names] %>%- |
-
330 | -! | -
- dplyr::mutate_if(is.character, as.factor) %>%- |
-
331 | -! | -
- droplevels(),- |
-
332 | -! | -
- env = list(cols_names = cols_names)- |
-
333 | -- |
- )- |
-
334 | -- |
- )- |
-
335 | -- |
- } else {- |
-
336 | -! | -
- qenv <- teal.code::eval_code(- |
-
337 | -! | -
- qenv,- |
-
338 | -! | -
- substitute(- |
-
339 | -! | -
- expr = ANL <- ANL[, cols_names] %>%- |
-
340 | -! | -
- droplevels(),- |
-
341 | -! | -
- env = list(cols_names = cols_names)- |
-
342 | -- |
- )- |
-
343 | -- |
- )- |
-
344 | -- |
- }- |
-
345 | -- | - - | -
346 | -- | - - | -
347 | -- |
- # create plot- |
-
348 | -! | -
- if (add_cor) {- |
-
349 | -! | -
- shinyjs::show("cor_method")- |
-
350 | -! | -
- shinyjs::show("cor_use")- |
-
351 | -! | -
- shinyjs::show("cor_na_omit")- |
-
352 | -- | - - | -
353 | -! | -
- qenv <- teal.code::eval_code(- |
-
354 | -! | -
- qenv,- |
-
355 | -! | -
- substitute(- |
-
356 | -! | -
- expr = {- |
-
357 | -! | -
- g <- lattice::splom(- |
-
358 | -! | -
- ANL,- |
-
359 | -! | -
- varnames = varnames_value,- |
-
360 | -! | -
- panel = function(x, y, ...) {- |
-
361 | -! | -
- lattice::panel.splom(x = x, y = y, ...)- |
-
362 | -! | -
- cpl <- lattice::current.panel.limits()- |
-
363 | -! | -
- lattice::panel.text(- |
-
364 | -! | -
- mean(cpl$xlim),- |
-
365 | -! | -
- mean(cpl$ylim),- |
-
366 | -! | -
- get_scatterplotmatrix_stats(- |
-
367 | -! | -
- x,- |
-
368 | -! | -
- y,- |
-
369 | -! | -
- .f = stats::cor.test,- |
-
370 | -! | -
- .f_args = list(method = cor_method, na.action = cor_na_action)- |
-
371 | -- |
- ),- |
-
372 | -! | -
- alpha = 0.6,- |
-
373 | -! | -
- fontsize = 18,- |
-
374 | -! | -
- fontface = "bold"- |
-
375 | -- |
- )- |
-
376 | -- |
- },- |
-
377 | -! | -
- pch = 16,- |
-
378 | -! | -
- alpha = alpha_value,- |
-
379 | -! | -
- cex = cex_value- |
-
380 | -- |
- )- |
-
381 | -! | -
- print(g)- |
-
382 | -- |
- },- |
-
383 | -! | -
- env = list(- |
-
384 | -! | -
- varnames_value = varnames,- |
-
385 | -! | -
- cor_method = cor_method,- |
-
386 | -! | -
- cor_na_action = cor_na_action,- |
-
387 | -! | -
- alpha_value = alpha,- |
-
388 | -! | -
- cex_value = cex- |
-
389 | -- |
- )- |
-
390 | -- |
- )- |
-
391 | -- |
- )- |
-
392 | -- |
- } else {- |
-
393 | -! | -
- shinyjs::hide("cor_method")- |
-
394 | -! | -
- shinyjs::hide("cor_use")- |
-
395 | -! | -
- shinyjs::hide("cor_na_omit")- |
-
396 | -! | -
- qenv <- teal.code::eval_code(- |
-
397 | -! | -
- qenv,- |
-
398 | -! | -
- substitute(- |
-
399 | -! | -
- expr = {- |
-
400 | -! | -
- g <- lattice::splom(ANL, varnames = varnames_value, pch = 16, alpha = alpha_value, cex = cex_value)- |
-
401 | -! | -
- g- |
-
402 | -- |
- },- |
-
403 | -! | -
- env = list(varnames_value = varnames, alpha_value = alpha, cex_value = cex)- |
-
404 | -- |
- )- |
-
405 | -- |
- )- |
-
406 | -- |
- }- |
-
407 | -! | -
- qenv- |
-
408 | -- |
- })- |
-
409 | -- | - - | -
410 | -! | -
- plot_r <- reactive(output_q()[["g"]])- |
-
411 | -- | - - | -
412 | -- |
- # Insert the plot into a plot_with_settings module- |
-
413 | -! | -
- pws <- teal.widgets::plot_with_settings_srv(- |
-
414 | -! | -
- id = "myplot",- |
-
415 | -! | -
- plot_r = plot_r,- |
-
416 | -! | -
- height = plot_height,- |
-
417 | -! | -
- width = plot_width- |
-
418 | -- |
- )- |
-
419 | -- | - - | -
420 | -- |
- # show a message if conversion to factors took place- |
-
421 | -! | -
- output$message <- renderText({- |
-
422 | -! | -
- shiny::req(iv_r()$is_valid())- |
-
423 | -! | -
- req(selector_list()$variables())- |
-
424 | -! | -
- ANL <- merged$anl_q_r()[["ANL"]]- |
-
425 | -! | -
- cols_names <- unique(unname(do.call(c, merged$anl_input_r()$columns_source)))- |
-
426 | -! | -
- check_char <- vapply(ANL[, cols_names], is.character, logical(1))- |
-
427 | -! | -
- if (any(check_char)) {- |
-
428 | -! | -
- is_single <- sum(check_char) == 1- |
-
429 | -! | -
- paste(- |
-
430 | -! | -
- "Character",- |
-
431 | -! | -
- ifelse(is_single, "variable", "variables"),- |
-
432 | -! | -
- paste0("(", paste(cols_names[check_char], collapse = ", "), ")"),- |
-
433 | -! | -
- ifelse(is_single, "was", "were"),- |
-
434 | -! | -
- "converted to",- |
-
435 | -! | -
- ifelse(is_single, "factor.", "factors.")- |
-
436 | -- |
- )- |
-
437 | -- |
- } else {- |
-
438 | -- |
- ""- |
-
439 | -- |
- }- |
-
440 | -- |
- })- |
-
441 | -- | - - | -
442 | -! | -
- teal.widgets::verbatim_popup_srv(- |
-
443 | -! | -
- id = "warning",- |
-
444 | -! | -
- verbatim_content = reactive(teal.code::get_warnings(output_q())),- |
-
445 | -! | -
- title = "Warning",- |
-
446 | -! | -
- disabled = reactive(is.null(teal.code::get_warnings(output_q())))- |
-
447 | -- |
- )- |
-
448 | -- | - - | -
449 | -! | -
- teal.widgets::verbatim_popup_srv(- |
-
450 | -! | -
- id = "rcode",- |
-
451 | -! | -
- verbatim_content = reactive(teal.code::get_code(output_q())),- |
-
452 | -! | -
- title = "Show R Code for Scatterplotmatrix"- |
-
453 | -- |
- )- |
-
454 | -- | - - | -
455 | -- |
- ### REPORTER- |
-
456 | -! | -
- if (with_reporter) {- |
-
457 | -! | -
- card_fun <- function(comment, label) {- |
-
458 | -! | -
- card <- teal::report_card_template(- |
-
459 | -! | -
- title = "Scatter Plot Matrix",- |
-
460 | -! | -
- label = label,- |
-
461 | -! | -
- with_filter = with_filter,- |
-
462 | -! | -
- filter_panel_api = filter_panel_api- |
-
463 | -- |
- )- |
-
464 | -! | -
- card$append_text("Plot", "header3")- |
-
465 | -! | -
- card$append_plot(plot_r(), dim = pws$dim())- |
-
466 | -! | -
- if (!comment == "") {- |
-
467 | -! | -
- card$append_text("Comment", "header3")- |
-
468 | -! | -
- card$append_text(comment)- |
-
469 | -- |
- }- |
-
470 | -! | -
- card$append_src(teal.code::get_code(output_q()))- |
-
471 | -! | -
- card- |
-
472 | -- |
- }- |
-
473 | -! | -
- teal.reporter::simple_reporter_srv("simple_reporter", reporter = reporter, card_fun = card_fun)- |
-
474 | -- |
- }- |
-
475 | -- |
- ###- |
-
476 | -- |
- })- |
-
477 | -- |
- }- |
-
478 | -- | - - | -
479 | -- |
- #' Get stats for x-y pairs in scatterplot matrix- |
-
480 | -- |
- #'- |
-
481 | -- |
- #' Uses [stats::cor.test()] per default for all numerical input variables and converts results- |
-
482 | -- |
- #' to character vector.- |
-
483 | -- |
- #' Could be extended if different stats for different variable types are needed.- |
-
484 | -- |
- #' Meant to be called from [lattice::panel.text()].- |
-
485 | -- |
- #'- |
-
486 | -- |
- #' Presently we need to use a formula input for `stats::cor.test` because- |
-
487 | -- |
- #' `na.fail` only gets evaluated when a formula is passed (see below).- |
-
488 | -- |
- #' ```- |
-
489 | -- |
- #' x = c(1,3,5,7,NA)- |
-
490 | -- |
- #' y = c(3,6,7,8,1)- |
-
491 | -- |
- #' stats::cor.test(x, y, na.action = "na.fail")- |
-
492 | -- |
- #' stats::cor.test(~ x + y, na.action = "na.fail")- |
-
493 | -- |
- #' ```- |
-
494 | -- |
- #'- |
-
495 | -- |
- #' @param x,y (`numeric`) vectors of data values. `x` and `y` must have the same length.- |
-
496 | -- |
- #' @param .f (`function`) function that accepts x and y as formula input `~ x + y`.- |
-
497 | -- |
- #' Default `stats::cor.test`.- |
-
498 | -- |
- #' @param .f_args (`list`) of arguments to be passed to `.f`.- |
-
499 | -- |
- #' @param round_stat (`integer(1)`) optional, number of decimal places to use when rounding the estimate.- |
-
500 | -- |
- #' @param round_pval (`integer(1)`) optional, number of decimal places to use when rounding the p-value.- |
-
501 | -- |
- #'- |
-
502 | -- |
- #' @return Character with stats. For [stats::cor.test()] correlation coefficient and p-value.- |
-
503 | -- |
- #'- |
-
504 | -- |
- #' @examples- |
-
505 | -- |
- #' set.seed(1)- |
-
506 | -- |
- #' x <- runif(25, 0, 1)- |
-
507 | -- |
- #' y <- runif(25, 0, 1)- |
-
508 | -- |
- #' x[c(3, 10, 18)] <- NA- |
-
509 | -- |
- #'- |
-
510 | -- |
- #' get_scatterplotmatrix_stats(x, y, .f = stats::cor.test, .f_args = list(method = "pearson"))- |
-
511 | -- |
- #' get_scatterplotmatrix_stats(x, y, .f = stats::cor.test, .f_args = list(- |
-
512 | -- |
- #' method = "pearson",- |
-
513 | -- |
- #' na.action = na.fail- |
-
514 | -- |
- #' ))- |
-
515 | -- |
- #'- |
-
516 | -- |
- #' @export- |
-
517 | -- |
- #'- |
-
518 | -- |
- get_scatterplotmatrix_stats <- function(x, y,- |
-
519 | -- |
- .f = stats::cor.test,- |
-
520 | -- |
- .f_args = list(),- |
-
521 | -- |
- round_stat = 2,- |
-
522 | -- |
- round_pval = 4) {- |
-
523 | -6x | -
- if (is.numeric(x) && is.numeric(y)) {- |
-
524 | -3x | -
- stat <- tryCatch(do.call(.f, c(list(~ x + y), .f_args)), error = function(e) NA)- |
-
525 | -- | - - | -
526 | -3x | -
- if (anyNA(stat)) {- |
-
527 | -1x | -
- return("NA")- |
-
528 | -2x | -
- } else if (all(c("estimate", "p.value") %in% names(stat))) {- |
-
529 | -2x | -
- return(paste(- |
-
530 | -2x | -
- c(- |
-
531 | -2x | -
- paste0(names(stat$estimate), ":", round(stat$estimate, round_stat)),- |
-
532 | -2x | -
- paste0("P:", round(stat$p.value, round_pval))- |
-
533 | -- |
- ),- |
-
534 | -2x | -
- collapse = "\n"- |
-
535 | -- |
- ))- |
-
536 | -- |
- } else {- |
-
537 | -! | -
- stop("function not supported")- |
-
538 | -- |
- }- |
-
539 | -- |
- } else {- |
-
540 | -3x | -
- if ("method" %in% names(.f_args)) {- |
-
541 | -3x | -
- if (.f_args$method == "pearson") {- |
-
542 | -1x | -
- return("cor:-")- |
-
543 | -- |
- }- |
-
544 | -2x | -
- if (.f_args$method == "kendall") {- |
-
545 | -1x | -
- return("tau:-")- |
-
546 | -- |
- }- |
-
547 | -1x | -
- if (.f_args$method == "spearman") {- |
-
548 | -1x | -
- return("rho:-")- |
-
549 | -- |
- }- |
-
550 | -- |
- }- |
-
551 | -! | -
- return("-")- |
-
552 | -- |
- }- |
-
553 | -- |
- }- |
-
1 | -- |
- #' Shared parameters documentation- |
-
2 | -- |
- #'- |
-
3 | -- |
- #' Defines common arguments shared across multiple functions in the package- |
-
4 | -- |
- #' to avoid repetition by using `inheritParams`.- |
-
5 | -- |
- #'- |
-
6 | -- |
- #' @param plot_height (`numeric`) optional, specifies the plot height as a three-element vector of- |
-
7 | -- |
- #' `value`, `min`, and `max` intended for use with a slider UI element.- |
-
8 | -- |
- #' @param plot_width (`numeric`) optional, specifies the plot width as a three-element vector of- |
-
9 | -- |
- #' `value`, `min`, and `max` for a slider encoding the plot width.- |
-
10 | -- |
- #' @param rotate_xaxis_labels (`logical`) optional, whether to rotate plot X axis labels. Does not- |
-
11 | -- |
- #' rotate by default (`FALSE`).- |
-
12 | -- |
- #' @param ggtheme (`character`) optional, `ggplot2` theme to be used by default. Defaults to `"gray"`.- |
-
13 | -- |
- #' @param ggplot2_args (`ggplot2_args`) object created by [teal.widgets::ggplot2_args()]- |
-
14 | -- |
- #' with settings for the module plot.- |
-
15 | -- |
- #' The argument is merged with options variable `teal.ggplot2_args` and default module setup.- |
-
16 | -- |
- #'- |
-
17 | -- |
- #' For more details see the vignette: `vignette("custom-ggplot2-arguments", package = "teal.widgets")`- |
-
18 | -- |
- #' @param basic_table_args (`basic_table_args`) object created by [teal.widgets::basic_table_args()]- |
-
19 | -- |
- #' with settings for the module table.- |
-
20 | -- |
- #' The argument is merged with options variable `teal.basic_table_args` and default module setup.- |
-
21 | -- |
- #'- |
-
22 | -- |
- #' For more details see the vignette: `vignette("custom-basic-table-arguments", package = "teal.widgets")`- |
-
23 | -- |
- #' @param pre_output (`shiny.tag`) optional, text or UI element to be displayed before the module's output,- |
-
24 | -- |
- #' providing context or a title.- |
-
25 | -- |
- #' with text placed before the output to put the output into context. For example a title.- |
-
26 | -- |
- #' @param post_output (`shiny.tag`) optional, text or UI element to be displayed after the module's output,- |
-
27 | -- |
- #' adding context or further instructions. Elements like `shiny::helpText()` are useful.- |
-
28 | -- |
- #'- |
-
29 | -- |
- #' @param alpha (`integer(1)` or `integer(3)`) optional, specifies point opacity.- |
-
30 | -- |
- #' - When the length of `alpha` is one: the plot points will have a fixed opacity.- |
-
31 | -- |
- #' - When the length of `alpha` is three: the plot points opacity are dynamically adjusted based on- |
-
32 | -- |
- #' vector of `value`, `min`, and `max`.- |
-
33 | -- |
- #' @param size (`integer(1)` or `integer(3)`) optional, specifies point size.- |
-
34 | -- |
- #' - When the length of `size` is one: the plot point sizes will have a fixed size.- |
-
35 | -- |
- #' - When the length of `size` is three: the plot points size are dynamically adjusted based on- |
-
36 | -- |
- #' vector of `value`, `min`, and `max`.- |
-
37 | -- |
- #'- |
-
38 | -- |
- #' @return Object of class `teal_module` to be used in `teal` applications.- |
-
39 | -- |
- #'- |
-
40 | -- |
- #' @name shared_params- |
-
41 | -- |
- #' @keywords internal- |
-
42 | -- |
- NULL- |
-
43 | -- | - - | -
44 | -- |
- #' Add labels for facets to a `ggplot2` object- |
-
45 | -- |
- #'- |
-
46 | -- |
- #' Enhances a `ggplot2` plot by adding labels that describe- |
-
47 | -- |
- #' the faceting variables along the x and y axes.- |
-
48 | -- |
- #'- |
-
49 | -- |
- #' @param p (`ggplot2`) object to which facet labels will be added.- |
-
50 | -- |
- #' @param xfacet_label (`character`) Label for the facet along the x-axis.- |
-
51 | -- |
- #' If `NULL`, no label is added. If a vector, labels are joined with " & ".- |
-
52 | -- |
- #' @param yfacet_label (`character`) Label for the facet along the y-axis.- |
-
53 | -- |
- #' Similar behavior to `xfacet_label`.- |
-
54 | -- |
- #'- |
-
55 | -- |
- #' @return Returns `grid` or `grob` object (to be drawn with `grid.draw`)- |
-
56 | -- |
- #'- |
-
57 | -- |
- #' @examples- |
-
58 | -- |
- #' library(ggplot2)- |
-
59 | -- |
- #' library(grid)- |
-
60 | -- |
- #'- |
-
61 | -- |
- #' p <- ggplot(mtcars) +- |
-
62 | -- |
- #' aes(x = mpg, y = disp) +- |
-
63 | -- |
- #' geom_point() +- |
-
64 | -- |
- #' facet_grid(gear ~ cyl)- |
-
65 | -- |
- #'- |
-
66 | -- |
- #' xfacet_label <- "cylinders"- |
-
67 | -- |
- #' yfacet_label <- "gear"- |
-
68 | -- |
- #' res <- add_facet_labels(p, xfacet_label, yfacet_label)- |
-
69 | -- |
- #' grid.newpage()- |
-
70 | -- |
- #' grid.draw(res)- |
-
71 | -- |
- #'- |
-
72 | -- |
- #' grid.newpage()- |
-
73 | -- |
- #' grid.draw(add_facet_labels(p, xfacet_label = NULL, yfacet_label))- |
-
74 | -- |
- #' grid.newpage()- |
-
75 | -- |
- #' grid.draw(add_facet_labels(p, xfacet_label, yfacet_label = NULL))- |
-
76 | -- |
- #' grid.newpage()- |
-
77 | -- |
- #' grid.draw(add_facet_labels(p, xfacet_label = NULL, yfacet_label = NULL))- |
-
78 | -- |
- #'- |
-
79 | -- |
- #' @export- |
-
80 | -- |
- #'- |
-
81 | -- |
- add_facet_labels <- function(p, xfacet_label = NULL, yfacet_label = NULL) {- |
-
82 | -! | -
- checkmate::assert_class(p, classes = "ggplot")- |
-
83 | -! | -
- checkmate::assert_character(xfacet_label, null.ok = TRUE, min.len = 1)- |
-
84 | -! | -
- checkmate::assert_character(yfacet_label, null.ok = TRUE, min.len = 1)- |
-
85 | -! | -
- if (is.null(xfacet_label) && is.null(yfacet_label)) {- |
-
86 | -! | -
- return(ggplotGrob(p))- |
-
87 | -- |
- }- |
-
88 | -! | -
- grid::grid.grabExpr({- |
-
89 | -! | -
- g <- ggplotGrob(p)- |
-
90 | -- | - - | -
91 | -- |
- # we are going to replace these, so we make sure they have nothing in them- |
-
92 | -! | -
- checkmate::assert_class(g$grobs[[grep("xlab-t", g$layout$name, fixed = TRUE)]], "zeroGrob")- |
-
93 | -! | -
- checkmate::assert_class(g$grobs[[grep("ylab-r", g$layout$name, fixed = TRUE)]], "zeroGrob")- |
-
94 | -- | - - | -
95 | -! | -
- xaxis_label_grob <- g$grobs[[grep("xlab-b", g$layout$name, fixed = TRUE)]]- |
-
96 | -! | -
- xaxis_label_grob$children[[1]]$label <- paste(xfacet_label, collapse = " & ")- |
-
97 | -! | -
- yaxis_label_grob <- g$grobs[[grep("ylab-l", g$layout$name, fixed = TRUE)]]- |
-
98 | -! | -
- yaxis_label_grob$children[[1]]$label <- paste(yfacet_label, collapse = " & ")- |
-
99 | -! | -
- yaxis_label_grob$children[[1]]$rot <- 270- |
-
100 | -- | - - | -
101 | -! | -
- top_height <- if (is.null(xfacet_label)) 0 else grid::unit(2, "line")- |
-
102 | -! | -
- right_width <- if (is.null(yfacet_label)) 0 else grid::unit(2, "line")- |
-
103 | -- | - - | -
104 | -! | -
- grid::grid.newpage()- |
-
105 | -! | -
- grid::pushViewport(grid::plotViewport(margins = c(0, 0, top_height, right_width), name = "ggplot"))- |
-
106 | -! | -
- grid::grid.draw(g)- |
-
107 | -! | -
- grid::upViewport(1)- |
-
108 | -- | - - | -
109 | -- |
- # draw x facet- |
-
110 | -! | -
- if (!is.null(xfacet_label)) {- |
-
111 | -! | -
- grid::pushViewport(grid::viewport(- |
-
112 | -! | -
- x = 0, y = grid::unit(1, "npc") - top_height, width = grid::unit(1, "npc"),- |
-
113 | -! | -
- height = top_height, just = c("left", "bottom"), name = "topxaxis"- |
-
114 | -- |
- ))- |
-
115 | -! | -
- grid::grid.draw(xaxis_label_grob)- |
-
116 | -! | -
- grid::upViewport(1)- |
-
117 | -- |
- }- |
-
118 | -- | - - | -
119 | -- |
- # draw y facet- |
-
120 | -! | -
- if (!is.null(yfacet_label)) {- |
-
121 | -! | -
- grid::pushViewport(grid::viewport(- |
-
122 | -! | -
- x = grid::unit(1, "npc") - grid::unit(as.numeric(right_width) / 2, "line"), y = 0, width = right_width,- |
-
123 | -! | -
- height = grid::unit(1, "npc"), just = c("left", "bottom"), name = "rightyaxis"- |
-
124 | -- |
- ))- |
-
125 | -! | -
- grid::grid.draw(yaxis_label_grob)- |
-
126 | -! | -
- grid::upViewport(1)- |
-
127 | -- |
- }- |
-
128 | -- |
- })- |
-
129 | -- |
- }- |
-
130 | -- | - - | -
131 | -- |
- #' Call a function with a character vector for the `...` argument- |
-
132 | -- |
- #'- |
-
133 | -- |
- #' @param fun (`character`) Name of a function where the `...` argument shall be replaced by values from `str_args`.- |
-
134 | -- |
- #' @param str_args (`character`) A character vector that the function shall be executed with- |
-
135 | -- |
- #'- |
-
136 | -- |
- #' @return- |
-
137 | -- |
- #' Value of call to `fun` with arguments specified in `str_args`.- |
-
138 | -- |
- #'- |
-
139 | -- |
- #' @keywords internal- |
-
140 | -- |
- call_fun_dots <- function(fun, str_args) {- |
-
141 | -! | -
- do.call("call", c(list(fun), lapply(str_args, as.name)), quote = TRUE)- |
-
142 | -- |
- }- |
-
143 | -- | - - | -
144 | -- |
- #' Generate a string for a variable including its label- |
-
145 | -- |
- #'- |
-
146 | -- |
- #' @param var_names (`character`) Name of variable to extract labels from.- |
-
147 | -- |
- #' @param dataset (`dataset`) Name of analysis dataset.- |
-
148 | -- |
- #' @param prefix,suffix (`character`) String to paste to the beginning/end of the variable name with label.- |
-
149 | -- |
- #' @param wrap_width (`numeric`) Number of characters to wrap original label to. Defaults to 80.- |
-
150 | -- |
- #'- |
-
151 | -- |
- #' @return (`character`) String with variable name and label.- |
-
152 | -- |
- #'- |
-
153 | -- |
- #' @keywords internal- |
-
154 | -- |
- #'- |
-
155 | -- |
- varname_w_label <- function(var_names,- |
-
156 | -- |
- dataset,- |
-
157 | -- |
- wrap_width = 80,- |
-
158 | -- |
- prefix = NULL,- |
-
159 | -- |
- suffix = NULL) {- |
-
160 | -! | -
- add_label <- function(var_names) {- |
-
161 | -! | -
- label <- vapply(- |
-
162 | -! | -
- dataset[var_names], function(x) {- |
-
163 | -! | -
- attr_label <- attr(x, "label")- |
-
164 | -! | -
- `if`(is.null(attr_label), "", attr_label)- |
-
165 | -- |
- },- |
-
166 | -! | -
- character(1)- |
-
167 | -- |
- )- |
-
168 | -- | - - | -
169 | -! | -
- if (length(label) == 1 && !is.na(label) && !identical(label, "")) {- |
-
170 | -! | -
- paste0(prefix, label, " [", var_names, "]", suffix)- |
-
171 | -- |
- } else {- |
-
172 | -! | -
- var_names- |
-
173 | -- |
- }- |
-
174 | -- |
- }- |
-
175 | -- | - - | -
176 | -! | -
- if (length(var_names) < 1) {- |
-
177 | -! | -
- NULL- |
-
178 | -! | -
- } else if (length(var_names) == 1) {- |
-
179 | -! | -
- stringr::str_wrap(add_label(var_names), width = wrap_width)- |
-
180 | -! | -
- } else if (length(var_names) > 1) {- |
-
181 | -! | -
- stringr::str_wrap(vapply(var_names, add_label, character(1)), width = wrap_width)- |
-
182 | -- |
- }- |
-
183 | -- |
- }- |
-
184 | -- | - - | -
185 | -- |
- # see vignette("ggplot2-specs", package="ggplot2")- |
-
186 | -- |
- shape_names <- c(- |
-
187 | -- |
- "circle", paste("circle", c("open", "filled", "cross", "plus", "small")), "bullet",- |
-
188 | -- |
- "square", paste("square", c("open", "filled", "cross", "plus", "triangle")),- |
-
189 | -- |
- "diamond", paste("diamond", c("open", "filled", "plus")),- |
-
190 | -- |
- "triangle", paste("triangle", c("open", "filled", "square")),- |
-
191 | -- |
- paste("triangle down", c("open", "filled")),- |
-
192 | -- |
- "plus", "cross", "asterisk"- |
-
193 | -- |
- )- |
-
194 | -- | - - | -
195 | -- |
- #' Get icons to represent variable types in dataset- |
-
196 | -- |
- #'- |
-
197 | -- |
- #' @param var_type (`character`) of R internal types (classes).- |
-
198 | -- |
- #' @return (`character`) vector of HTML icons corresponding to data type in each column.- |
-
199 | -- |
- #' @keywords internal- |
-
200 | -- |
- variable_type_icons <- function(var_type) {- |
-
201 | -! | -
- checkmate::assert_character(var_type, any.missing = FALSE)- |
-
202 | -- | - - | -
203 | -! | -
- class_to_icon <- list(- |
-
204 | -! | -
- numeric = "arrow-up-1-9",- |
-
205 | -! | -
- integer = "arrow-up-1-9",- |
-
206 | -! | -
- logical = "pause",- |
-
207 | -! | -
- Date = "calendar",- |
-
208 | -! | -
- POSIXct = "calendar",- |
-
209 | -! | -
- POSIXlt = "calendar",- |
-
210 | -! | -
- factor = "chart-bar",- |
-
211 | -! | -
- character = "keyboard",- |
-
212 | -! | -
- primary_key = "key",- |
-
213 | -! | -
- unknown = "circle-question"- |
-
214 | -- |
- )- |
-
215 | -! | -
- class_to_icon <- lapply(class_to_icon, function(icon_name) toString(icon(icon_name, lib = "font-awesome")))- |
-
216 | -- | - - | -
217 | -! | -
- unname(vapply(- |
-
218 | -! | -
- var_type,- |
-
219 | -! | -
- FUN.VALUE = character(1),- |
-
220 | -! | -
- FUN = function(class) {- |
-
221 | -! | -
- if (class == "") {- |
-
222 | -! | -
- class- |
-
223 | -! | -
- } else if (is.null(class_to_icon[[class]])) {- |
-
224 | -! | -
- class_to_icon[["unknown"]]- |
-
225 | -- |
- } else {- |
-
226 | -! | -
- class_to_icon[[class]]- |
-
227 | -- |
- }- |
-
228 | -- |
- }- |
-
229 | -- |
- ))- |
-
230 | -- |
- }- |
-
231 | -- | - - | -
232 | -- |
- #' Include `CSS` files from `/inst/css/` package directory to application header- |
-
233 | -- |
- #'- |
-
234 | -- |
- #' `system.file` should not be used to access files in other packages, it does- |
-
235 | -- |
- #' not work with `devtools`. Therefore, we redefine this method in each package- |
-
236 | -- |
- #' as needed. Thus, we do not export this method- |
-
237 | -- |
- #'- |
-
238 | -- |
- #' @param pattern (`character`) optional, regular expression to match the file names to be included.- |
-
239 | -- |
- #'- |
-
240 | -- |
- #' @return HTML code that includes `CSS` files.- |
-
241 | -- |
- #' @keywords internal- |
-
242 | -- |
- #'- |
-
243 | -- |
- include_css_files <- function(pattern = "*") {- |
-
244 | -! | -
- css_files <- list.files(- |
-
245 | -! | -
- system.file("css", package = "teal.modules.general", mustWork = TRUE),- |
-
246 | -! | -
- pattern = pattern, full.names = TRUE- |
-
247 | -- |
- )- |
-
248 | -! | -
- if (length(css_files) == 0) {- |
-
249 | -! | -
- return(NULL)- |
-
250 | -- |
- }- |
-
251 | -! | -
- shiny::singleton(shiny::tags$head(lapply(css_files, shiny::includeCSS)))- |
-
252 | -- |
- }- |
-
253 | -- | - - | -
254 | -- |
- #' JavaScript condition to check if a specific tab is active- |
-
255 | -- |
- #'- |
-
256 | -- |
- #' @param id (`character(1)`) the id of the tab panel with tabs.- |
-
257 | -- |
- #' @param name (`character(1)`) the name of the tab.- |
-
258 | -- |
- #' @return JavaScript expression to be used in `shiny::conditionalPanel()` to determine- |
-
259 | -- |
- #' if the specified tab is active.- |
-
260 | -- |
- #' @keywords internal- |
-
261 | -- |
- #'- |
-
262 | -- |
- is_tab_active_js <- function(id, name) {- |
-
263 | -- |
- # supporting the bs3 and higher version at the same time- |
-
264 | -! | -
- sprintf(- |
-
265 | -! | -
- "$(\"#%1$s > li.active\").text().trim() == '%2$s' || $(\"#%1$s > li a.active\").text().trim() == '%2$s'",- |
-
266 | -! | -
- id, name- |
-
267 | -- |
- )- |
-
268 | -- |
- }- |
-
269 | -- | - - | -
270 | -- |
- #' Assert single selection on `data_extract_spec` object- |
-
271 | -- |
- #' Helper to reduce code in assertions- |
-
272 | -- |
- #' @noRd- |
-
273 | -- |
- #'- |
-
274 | -- |
- assert_single_selection <- function(x,- |
-
275 | -- |
- .var.name = checkmate::vname(x)) { # nolint: object_name.- |
-
276 | -104x | -
- if (any(vapply(x, function(.x) .x$select$multiple, logical(1)))) {- |
-
277 | -4x | -
- stop("'", .var.name, "' should not allow multiple selection")- |
-
278 | -- |
- }- |
-
279 | -100x | -
- invisible(TRUE)- |
-
280 | -- |
- }- |
-
1 | -- |
- #' `teal` module: Data table viewer- |
-
2 | -- |
- #'- |
-
3 | -- |
- #' Module provides a dynamic and interactive way to view `data.frame`s in a `teal` application.- |
-
4 | -- |
- #' It uses the `DT` package to display data tables in a paginated, searchable, and sortable format,- |
-
5 | -- |
- #' which helps to enhance data exploration and analysis.- |
-
6 | -- |
- #'- |
-
7 | -- |
- #' The `DT` package has an option `DT.TOJSON_ARGS` to show `Inf` and `NA` in data tables.- |
-
8 | -- |
- #' Configure the `DT.TOJSON_ARGS` option via- |
-
9 | -- |
- #' `options(DT.TOJSON_ARGS = list(na = "string"))` before running the module.- |
-
10 | -- |
- #' Note though that sorting of numeric columns with `NA`/`Inf` will be lexicographic not numerical.- |
-
11 | -- |
- #'- |
-
12 | -- |
- #' @inheritParams teal::module- |
-
13 | -- |
- #' @inheritParams shared_params- |
-
14 | -- |
- #' @param variables_selected (`named list`) Character vectors of the variables (i.e. columns)- |
-
15 | -- |
- #' which should be initially shown for each dataset.- |
-
16 | -- |
- #' Names of list elements should correspond to the names of the datasets available in the app.- |
-
17 | -- |
- #' If no entry is specified for a dataset, the first six variables from that- |
-
18 | -- |
- #' dataset will initially be shown.- |
-
19 | -- |
- #' @param datasets_selected (`character`) A vector of datasets which should be- |
-
20 | -- |
- #' shown and in what order. Names in the vector have to correspond with datasets names.- |
-
21 | -- |
- #' If vector of `length == 0` (default) then all datasets are shown.- |
-
22 | -- |
- #' Note: Only datasets of the `data.frame` class are compatible.- |
-
23 | -- |
- #' @param dt_args (`named list`) Additional arguments to be passed to [DT::datatable()]- |
-
24 | -- |
- #' (must not include `data` or `options`).- |
-
25 | -- |
- #' @param dt_options (`named list`) The `options` argument to `DT::datatable`. By default- |
-
26 | -- |
- #' `list(searching = FALSE, pageLength = 30, lengthMenu = c(5, 15, 30, 100), scrollX = TRUE)`- |
-
27 | -- |
- #' @param server_rendering (`logical`) should the data table be rendered server side- |
-
28 | -- |
- #' (see `server` argument of [DT::renderDataTable()])- |
-
29 | -- |
- #'- |
-
30 | -- |
- #' @inherit shared_params return- |
-
31 | -- |
- #'- |
-
32 | -- |
- #' @examples- |
-
33 | -- |
- #' # general data example- |
-
34 | -- |
- #' data <- teal_data()- |
-
35 | -- |
- #' data <- within(data, {- |
-
36 | -- |
- #' require(nestcolor)- |
-
37 | -- |
- #' iris <- iris- |
-
38 | -- |
- #' })- |
-
39 | -- |
- #' datanames(data) <- c("iris")- |
-
40 | -- |
- #'- |
-
41 | -- |
- #' app <- init(- |
-
42 | -- |
- #' data = data,- |
-
43 | -- |
- #' modules = modules(- |
-
44 | -- |
- #' tm_data_table(- |
-
45 | -- |
- #' variables_selected = list(- |
-
46 | -- |
- #' iris = c("Sepal.Length", "Sepal.Width", "Petal.Length", "Petal.Width", "Species")- |
-
47 | -- |
- #' ),- |
-
48 | -- |
- #' dt_args = list(caption = "ADSL Table Caption")- |
-
49 | -- |
- #' )- |
-
50 | -- |
- #' )- |
-
51 | -- |
- #' )- |
-
52 | -- |
- #' if (interactive()) {- |
-
53 | -- |
- #' shinyApp(app$ui, app$server)- |
-
54 | -- |
- #' }- |
-
55 | -- |
- #'- |
-
56 | -- |
- #' # CDISC data example- |
-
57 | -- |
- #' data <- teal_data()- |
-
58 | -- |
- #' data <- within(data, {- |
-
59 | -- |
- #' require(nestcolor)- |
-
60 | -- |
- #' ADSL <- rADSL- |
-
61 | -- |
- #' })- |
-
62 | -- |
- #' datanames(data) <- "ADSL"- |
-
63 | -- |
- #' join_keys(data) <- default_cdisc_join_keys[datanames(data)]- |
-
64 | -- |
- #'- |
-
65 | -- |
- #' app <- init(- |
-
66 | -- |
- #' data = data,- |
-
67 | -- |
- #' modules = modules(- |
-
68 | -- |
- #' tm_data_table(- |
-
69 | -- |
- #' variables_selected = list(ADSL = c("STUDYID", "USUBJID", "SUBJID", "SITEID", "AGE", "SEX")),- |
-
70 | -- |
- #' dt_args = list(caption = "ADSL Table Caption")- |
-
71 | -- |
- #' )- |
-
72 | -- |
- #' )- |
-
73 | -- |
- #' )- |
-
74 | -- |
- #' if (interactive()) {- |
-
75 | -- |
- #' shinyApp(app$ui, app$server)- |
-
76 | -- |
- #' }- |
-
77 | -- |
- #'- |
-
78 | -- |
- #' @export- |
-
79 | -- |
- #'- |
-
80 | -- |
- tm_data_table <- function(label = "Data Table",- |
-
81 | -- |
- variables_selected = list(),- |
-
82 | -- |
- datasets_selected = character(0),- |
-
83 | -- |
- dt_args = list(),- |
-
84 | -- |
- dt_options = list(- |
-
85 | -- |
- searching = FALSE,- |
-
86 | -- |
- pageLength = 30,- |
-
87 | -- |
- lengthMenu = c(5, 15, 30, 100),- |
-
88 | -- |
- scrollX = TRUE- |
-
89 | -- |
- ),- |
-
90 | -- |
- server_rendering = FALSE,- |
-
91 | -- |
- pre_output = NULL,- |
-
92 | -- |
- post_output = NULL) {- |
-
93 | -! | -
- logger::log_info("Initializing tm_data_table")- |
-
94 | -- | - - | -
95 | -- |
- # Start of assertions- |
-
96 | -! | -
- checkmate::assert_string(label)- |
-
97 | -- | - - | -
98 | -! | -
- checkmate::assert_list(variables_selected, min.len = 0, types = "character", names = "named")- |
-
99 | -! | -
- if (length(variables_selected) > 0) {- |
-
100 | -! | -
- lapply(seq_along(variables_selected), function(i) {- |
-
101 | -! | -
- checkmate::assert_character(variables_selected[[i]], min.chars = 1, min.len = 1)- |
-
102 | -! | -
- if (!is.null(names(variables_selected[[i]]))) {- |
-
103 | -! | -
- checkmate::assert_names(names(variables_selected[[i]]))- |
-
104 | -- |
- }- |
-
105 | -- |
- })- |
-
106 | -- |
- }- |
-
107 | -- | - - | -
108 | -! | -
- checkmate::assert_character(datasets_selected, min.len = 0, min.chars = 1)- |
-
109 | -! | -
- checkmate::assert(- |
-
110 | -! | -
- checkmate::check_list(dt_args, len = 0),- |
-
111 | -! | -
- checkmate::check_subset(names(dt_args), choices = names(formals(DT::datatable)))- |
-
112 | -- |
- )- |
-
113 | -! | -
- checkmate::assert_list(dt_options, names = "named")- |
-
114 | -! | -
- checkmate::assert_flag(server_rendering)- |
-
115 | -! | -
- checkmate::assert_multi_class(pre_output, c("shiny.tag", "shiny.tag.list", "html"), null.ok = TRUE)- |
-
116 | -! | -
- checkmate::assert_multi_class(post_output, c("shiny.tag", "shiny.tag.list", "html"), null.ok = TRUE)- |
-
117 | -- |
- # End of assertions- |
-
118 | -- | - - | -
119 | -! | -
- module(- |
-
120 | -! | -
- label,- |
-
121 | -! | -
- server = srv_page_data_table,- |
-
122 | -! | -
- ui = ui_page_data_table,- |
-
123 | -! | -
- datanames = if (length(datasets_selected) == 0) "all" else datasets_selected,- |
-
124 | -! | -
- server_args = list(- |
-
125 | -! | -
- variables_selected = variables_selected,- |
-
126 | -! | -
- datasets_selected = datasets_selected,- |
-
127 | -! | -
- dt_args = dt_args,- |
-
128 | -! | -
- dt_options = dt_options,- |
-
129 | -! | -
- server_rendering = server_rendering- |
-
130 | -- |
- ),- |
-
131 | -! | -
- ui_args = list(- |
-
132 | -! | -
- pre_output = pre_output,- |
-
133 | -! | -
- post_output = post_output- |
-
134 | -- |
- )- |
-
135 | -- |
- )- |
-
136 | -- |
- }- |
-
137 | -- | - - | -
138 | -- |
- # UI page module- |
-
139 | -- |
- ui_page_data_table <- function(id,- |
-
140 | -- |
- pre_output = NULL,- |
-
141 | -- |
- post_output = NULL) {- |
-
142 | -! | -
- ns <- NS(id)- |
-
143 | -- | - - | -
144 | -! | -
- shiny::tagList(- |
-
145 | -! | -
- include_css_files("custom"),- |
-
146 | -! | -
- teal.widgets::standard_layout(- |
-
147 | -! | -
- output = teal.widgets::white_small_well(- |
-
148 | -! | -
- fluidRow(- |
-
149 | -! | -
- column(- |
-
150 | -! | -
- width = 12,- |
-
151 | -! | -
- checkboxInput(- |
-
152 | -! | -
- ns("if_distinct"),- |
-
153 | -! | -
- "Show only distinct rows:",- |
-
154 | -! | -
- value = FALSE- |
-
155 | -- |
- )- |
-
156 | -- |
- )- |
-
157 | -- |
- ),- |
-
158 | -! | -
- fluidRow(- |
-
159 | -! | -
- class = "mb-8",- |
-
160 | -! | -
- column(- |
-
161 | -! | -
- width = 12,- |
-
162 | -! | -
- uiOutput(ns("dataset_table"))- |
-
163 | -- |
- )- |
-
164 | -- |
- )- |
-
165 | -- |
- ),- |
-
166 | -! | -
- pre_output = pre_output,- |
-
167 | -! | -
- post_output = post_output- |
-
168 | -- |
- )- |
-
169 | -- |
- )- |
-
170 | -- |
- }- |
-
171 | -- | - - | -
172 | -- |
- # Server page module- |
-
173 | -- |
- srv_page_data_table <- function(id,- |
-
174 | -- |
- data,- |
-
175 | -- |
- datasets_selected,- |
-
176 | -- |
- variables_selected,- |
-
177 | -- |
- dt_args,- |
-
178 | -- |
- dt_options,- |
-
179 | -- |
- server_rendering) {- |
-
180 | -! | -
- checkmate::assert_class(data, "reactive")- |
-
181 | -! | -
- checkmate::assert_class(isolate(data()), "teal_data")- |
-
182 | -! | -
- moduleServer(id, function(input, output, session) {- |
-
183 | -! | -
- if_filtered <- reactive(as.logical(input$if_filtered))- |
-
184 | -! | -
- if_distinct <- reactive(as.logical(input$if_distinct))- |
-
185 | -- | - - | -
186 | -! | -
- datanames <- isolate(teal.data::datanames(data()))- |
-
187 | -! | -
- datanames <- Filter(function(name) {- |
-
188 | -! | -
- is.data.frame(isolate(data())[[name]])- |
-
189 | -! | -
- }, datanames)- |
-
190 | -- | - - | -
191 | -! | -
- if (!identical(datasets_selected, character(0))) {- |
-
192 | -! | -
- checkmate::assert_subset(datasets_selected, datanames)- |
-
193 | -! | -
- datanames <- datasets_selected- |
-
194 | -- |
- }- |
-
195 | -- | - - | -
196 | -! | -
- output$dataset_table <- renderUI({- |
-
197 | -! | -
- do.call(- |
-
198 | -! | -
- tabsetPanel,- |
-
199 | -! | -
- lapply(- |
-
200 | -! | -
- datanames,- |
-
201 | -! | -
- function(x) {- |
-
202 | -! | -
- dataset <- isolate(data()[[x]])- |
-
203 | -! | -
- choices <- names(dataset)- |
-
204 | -! | -
- labels <- vapply(- |
-
205 | -! | -
- dataset,- |
-
206 | -! | -
- function(x) ifelse(is.null(attr(x, "label")), "", attr(x, "label")),- |
-
207 | -! | -
- character(1)- |
-
208 | -- |
- )- |
-
209 | -! | -
- names(choices) <- ifelse(- |
-
210 | -! | -
- is.na(labels) | labels == "",- |
-
211 | -! | -
- choices,- |
-
212 | -! | -
- paste(choices, labels, sep = ": ")- |
-
213 | -- |
- )- |
-
214 | -! | -
- variables_selected <- if (!is.null(variables_selected[[x]])) {- |
-
215 | -! | -
- variables_selected[[x]]- |
-
216 | -- |
- } else {- |
-
217 | -! | -
- utils::head(choices)- |
-
218 | -- |
- }- |
-
219 | -! | -
- tabPanel(- |
-
220 | -! | -
- title = x,- |
-
221 | -! | -
- column(- |
-
222 | -! | -
- width = 12,- |
-
223 | -! | -
- div(- |
-
224 | -! | -
- class = "mt-4",- |
-
225 | -! | -
- ui_data_table(- |
-
226 | -! | -
- id = session$ns(x),- |
-
227 | -! | -
- choices = choices,- |
-
228 | -! | -
- selected = variables_selected- |
-
229 | -- |
- )- |
-
230 | -- |
- )- |
-
231 | -- |
- )- |
-
232 | -- |
- )- |
-
233 | -- |
- }- |
-
234 | -- |
- )- |
-
235 | -- |
- )- |
-
236 | -- |
- })- |
-
237 | -- | - - | -
238 | -! | -
- lapply(- |
-
239 | -! | -
- datanames,- |
-
240 | -! | -
- function(x) {- |
-
241 | -! | -
- srv_data_table(- |
-
242 | -! | -
- id = x,- |
-
243 | -! | -
- data = data,- |
-
244 | -! | -
- dataname = x,- |
-
245 | -! | -
- if_filtered = if_filtered,- |
-
246 | -! | -
- if_distinct = if_distinct,- |
-
247 | -! | -
- dt_args = dt_args,- |
-
248 | -! | -
- dt_options = dt_options,- |
-
249 | -! | -
- server_rendering = server_rendering- |
-
250 | -- |
- )- |
-
251 | -- |
- }- |
-
252 | -- |
- )- |
-
253 | -- |
- })- |
-
254 | -- |
- }- |
-
255 | -- | - - | -
256 | -- |
- # UI function for the data_table module- |
-
257 | -- |
- ui_data_table <- function(id,- |
-
258 | -- |
- choices,- |
-
259 | -- |
- selected) {- |
-
260 | -! | -
- ns <- NS(id)- |
-
261 | -- | - - | -
262 | -! | -
- if (!is.null(selected)) {- |
-
263 | -! | -
- all_choices <- choices- |
-
264 | -! | -
- choices <- c(selected, setdiff(choices, selected))- |
-
265 | -! | -
- names(choices) <- names(all_choices)[match(choices, all_choices)]- |
-
266 | -- |
- }- |
-
267 | -- | - - | -
268 | -! | -
- tagList(- |
-
269 | -! | -
- teal.widgets::get_dt_rows(ns("data_table"), ns("dt_rows")),- |
-
270 | -! | -
- fluidRow(- |
-
271 | -! | -
- teal.widgets::optionalSelectInput(- |
-
272 | -! | -
- ns("variables"),- |
-
273 | -! | -
- "Select variables:",- |
-
274 | -! | -
- choices = choices,- |
-
275 | -! | -
- selected = selected,- |
-
276 | -! | -
- multiple = TRUE,- |
-
277 | -! | -
- width = "100%"- |
-
278 | -- |
- )- |
-
279 | -- |
- ),- |
-
280 | -! | -
- fluidRow(- |
-
281 | -! | -
- DT::dataTableOutput(ns("data_table"), width = "100%")- |
-
282 | -- |
- )- |
-
283 | -- |
- )- |
-
284 | -- |
- }- |
-
285 | -- | - - | -
286 | -- |
- # Server function for the data_table module- |
-
287 | -- |
- srv_data_table <- function(id,- |
-
288 | -- |
- data,- |
-
289 | -- |
- dataname,- |
-
290 | -- |
- if_filtered,- |
-
291 | -- |
- if_distinct,- |
-
292 | -- |
- dt_args,- |
-
293 | -- |
- dt_options,- |
-
294 | -- |
- server_rendering) {- |
-
295 | -! | -
- moduleServer(id, function(input, output, session) {- |
-
296 | -! | -
- iv <- shinyvalidate::InputValidator$new()- |
-
297 | -! | -
- iv$add_rule("variables", shinyvalidate::sv_required("Please select valid variable names"))- |
-
298 | -! | -
- iv$add_rule("variables", shinyvalidate::sv_in_set(- |
-
299 | -! | -
- set = names(data()[[dataname]]), message_fmt = "Not all selected variables exist in the data"- |
-
300 | -- |
- ))- |
-
301 | -! | -
- iv$enable()- |
-
302 | -- | - - | -
303 | -! | -
- output$data_table <- DT::renderDataTable(server = server_rendering, {- |
-
304 | -! | -
- teal::validate_inputs(iv)- |
-
305 | -- | - - | -
306 | -! | -
- df <- data()[[dataname]]- |
-
307 | -! | -
- variables <- input$variables- |
-
308 | -- | - - | -
309 | -! | -
- teal::validate_has_data(df, min_nrow = 1L, msg = paste("data", dataname, "is empty"))- |
-
310 | -- | - - | -
311 | -! | -
- dataframe_selected <- if (if_distinct()) {- |
-
312 | -! | -
- dplyr::count(df, dplyr::across(dplyr::all_of(variables)))- |
-
313 | -- |
- } else {- |
-
314 | -! | -
- df[variables]- |
-
315 | -- |
- }- |
-
316 | -- | - - | -
317 | -! | -
- dt_args$options <- dt_options- |
-
318 | -! | -
- if (!is.null(input$dt_rows)) {- |
-
319 | -! | -
- dt_args$options$pageLength <- input$dt_rows- |
-
320 | -- |
- }- |
-
321 | -! | -
- dt_args$data <- dataframe_selected- |
-
322 | -- | - - | -
323 | -! | -
- do.call(DT::datatable, dt_args)- |
-
324 | -- |
- })- |
-
325 | -- |
- })- |
-
326 | -- |
- }- |
-
1 | -- |
- .onLoad <- function(libname, pkgname) {- |
-
2 | -! | -
- teal.logger::register_logger(namespace = "teal.modules.general")- |
-
3 | -- |
- }- |
-
4 | -- | - - | -
5 | -- |
- ### global variables- |
-
6 | -- |
- ggplot_themes <- c("gray", "bw", "linedraw", "light", "dark", "minimal", "classic", "void")- |
-