From 118b0da2204dff3d923002d27bfdb7f8e4bb7aa2 Mon Sep 17 00:00:00 2001
From: "arsenij.ustjanzew" <arsenij.ustjanzew@mpi-bn.mpg.de>
Date: Thu, 2 Apr 2020 12:42:17 +0200
Subject: [PATCH] Added ANY signature to add_component for a generic way to add
htmlwidgets
---
DESCRIPTION | 1 +
R/components.R | 2 +-
R/vis_objects.R | 65 +++++++++++++----------------------
inst/templates/vis_object.Rmd | 2 +-
4 files changed, 26 insertions(+), 44 deletions(-)
diff --git a/DESCRIPTION b/DESCRIPTION
index 674c5f7..f638530 100644
--- a/DESCRIPTION
+++ b/DESCRIPTION
@@ -23,6 +23,7 @@ Imports:
glue,
ymlthis
Suggests:
+ switchr,
highcharter,
plotly,
crosstalk,
diff --git a/R/components.R b/R/components.R
index 0ebb9b9..dc726f3 100644
--- a/R/components.R
+++ b/R/components.R
@@ -59,7 +59,7 @@ setMethod("add_component",
})
setMethod("add_component", signature(dashboard = "i2dashboard", component = "function"),
- function(dashboard, component, page = "default", title = NULL, ...) {
+ function(dashboard, component, page = "default", ...) {
# validate "page" input
name <- .create_page_name(page)
if (!(name %in% names(dashboard@pages))) {
diff --git a/R/vis_objects.R b/R/vis_objects.R
index 0ac3237..3f2c244 100644
--- a/R/vis_objects.R
+++ b/R/vis_objects.R
@@ -29,7 +29,7 @@ add_vis_object <- function(dashboard, object, package, page = "default", title =
delim = c("<%", "%>"),
title = title,
package = package,
- class = class(object),
+ class = is(object),
component_id = component_id,
timestamp = timestamp)
@@ -42,61 +42,42 @@ add_vis_object <- function(dashboard, object, package, page = "default", title =
# Methods to add common visualization objects
#
setMethod("add_component",
- signature = signature(dashboard = "i2dashboard", component = "highchart"),
+ signature = signature(dashboard = "i2dashboard", component = "gg"),
definition = function(dashboard, component, page = "default", title = NULL, ...) {
- add_vis_object(dashboard, component, "highcharter", page, title, ...) })
+ add_vis_object(dashboard, component, "ggplot2", page, title, ...) })
setMethod("add_component",
- signature = signature(dashboard = "i2dashboard", component = "plotly"),
+ signature = signature(dashboard = "i2dashboard", component = "gt_tbl"),
definition = function(dashboard, component, page = "default", title = NULL, ...) {
- add_vis_object(dashboard, component, "plotly", page, title, ...) })
+ add_vis_object(dashboard, component,"gt", page, title, ...) })
setMethod("add_component",
- signature = signature(dashboard = "i2dashboard", component = "leaflet"),
+ signature = signature(dashboard = "i2dashboard", component = "knitr_kable"),
definition = function(dashboard, component, page = "default", title = NULL, ...) {
- add_vis_object(dashboard, component, "leaflet", page, title, ...) })
+ add_vis_object(dashboard, component, "kableExtra", page, title, ...) })
setMethod("add_component",
- signature = signature(dashboard = "i2dashboard", component = "dygraphs"),
+ signature = signature(dashboard = "i2dashboard", component = "Heatmap"),
definition = function(dashboard, component, page = "default", title = NULL, ...) {
- add_vis_object(dashboard, component, "dygraphs", page, title, ...) })
+ add_vis_object(dashboard, component, "ComplexHeatmap", page, title, ...) })
setMethod("add_component",
- signature = signature(dashboard = "i2dashboard", component = "rbokeh"),
+ signature = signature(dashboard = "i2dashboard", component = "ANY"),
definition = function(dashboard, component, page = "default", title = NULL, ...) {
- add_vis_object(dashboard, component, "rbokeh", page, title, ...) })
-setMethod("add_component",
- signature = signature(dashboard = "i2dashboard", component = "visNetwork"),
- definition = function(dashboard, component, page = "default", title = NULL, ...) {
- add_vis_object(dashboard, component, "visNetwork", page, title, ...) })
+ # HTMLWIDGETS
+ if(inherits(component, "htmlwidget")) {
+ package <- packageSlot(component)
-setMethod("add_component",
- signature = signature(dashboard = "i2dashboard", component = "d3heatmap"),
- definition = function(dashboard, component, page = "default", title = NULL, ...) {
- add_vis_object(dashboard, component, "d3heatmap", page, title, ...) })
+ if(is.null(package)) {
+ warning("No component added, since the package name of the HTML widget could not be determined.")
+ return(dashboard)
+ }
-setMethod("add_component",
- signature = signature(dashboard = "i2dashboard", component = "metricsgraphics"),
- definition = function(dashboard, component, page = "default", title = NULL, ...) {
- add_vis_object(dashboard, component, "metricsgraphics", page, title, ...) })
+ return(add_vis_object(dashboard, component, package, page, title, ...))
+ }
-setMethod("add_component",
- signature = signature(dashboard = "i2dashboard", component = "gg"),
- definition = function(dashboard, component, page = "default", title = NULL, ...) {
- add_vis_object(dashboard, component, "ggplot2", page, title, ...) })
-
-setMethod("add_component",
- signature = signature(dashboard = "i2dashboard", component = "datatables"),
- definition = function(dashboard, component, page = "default", title = NULL, ...) {
- add_vis_object(dashboard, component, "DT", page, title, ...) })
-
-setMethod("add_component",
- signature = signature(dashboard = "i2dashboard", component = "grViz"),
- definition = function(dashboard, component, page = "default", title = NULL, ...) {
- add_vis_object(dashboard, component, "DiagrammeR", page, title, ...) })
-
-setMethod("add_component",
- signature = signature(dashboard = "i2dashboard", component = "gt_tbl"),
- definition = function(dashboard, component, page = "default", title = NULL, ...) {
- add_vis_object(dashboard, component, "gt", page, title, ...) })
+ # OTHER
+ warning("The component did not inherit from any of the currently supported classes ('htmlwidget').")
+ return(dashboard)
+ })
diff --git a/inst/templates/vis_object.Rmd b/inst/templates/vis_object.Rmd
index a43ef1c..88f0960 100644
--- a/inst/templates/vis_object.Rmd
+++ b/inst/templates/vis_object.Rmd
@@ -4,7 +4,7 @@
```{r}
if (!requireNamespace("<% package %>", quietly = TRUE)) {
- stop('The package <% package %> is needed to embed objects of class <% class %>.', call. = FALSE)
+ stop('The package "<% package %>" is needed to embed objects of class "<% class %>".', call. = FALSE)
}
vis_<% component_id %> <- readRDS(file.path(datadir, '<% component_id %>.rds'))
--
GitLab