See merge request !21

DESCRIPTION

@@ -32,7 +32,15 @@ Suggests:
     plotly,
     BiocStyle,
     xfun,
-    htmltools
+    htmltools,
+    testthat,
+    ComplexHeatmap,
+    digest,
+    ggplot2,
+    gt,
+    kableExtra,
+    forcats,
+    leaflet
 Collate: 
     'i2dashboard.R'
     'AllGenerics.R'

NAMESPACE

@@ -5,7 +5,7 @@ export("author<-")
 export("datadir<-")
 export("embed_source<-")
 export("interactivity<-")
-export("social_links<-")
+export("share<-")
 export("source<-")
 export("theme<-")
 export("title<-")
@@ -21,7 +21,7 @@ export(embed_var)
 export(i2dashboard)
 export(interactivity)
 export(remove_page)
-export(social_links)
+export(share)
 export(source)
 export(theme)
 export(title)

R/AllGenerics.R

@@ -65,11 +65,11 @@ setGeneric("datadir<-", function(dashboard, value) standardGeneric("datadir<-"))
 
 #' @export
 #' @rdname i2dashboard-methods
-setGeneric("social_links", function(dashboard) standardGeneric("social_links"))
+setGeneric("share", function(dashboard) standardGeneric("share"))
 
 #' @export
 #' @rdname i2dashboard-methods
-setGeneric("social_links<-", function(dashboard, value) standardGeneric("social_links<-"))
+setGeneric("share<-", function(dashboard, value) standardGeneric("share<-"))
 
 #' @export
 #' @rdname i2dashboard-methods

R/assemble.R

@@ -27,10 +27,10 @@ setMethod("assemble", "i2dashboard", function(dashboard, pages = names(dashboard
   } else {
     source <- dashboard@source
   }
-  if (dashboard@social == "") {
+  if (dashboard@share == "") {
     social <- NULL
   } else {
-    social <- dashboard@social
+    social <- dashboard@share
   }
 
   # Add YAML header

R/components.R

@@ -20,8 +20,8 @@
 #' }
 #'
 #' @param dashboard A \linkS4class{i2dashboard}.
-#' @param page The name of the page to add the component or sidebar to.
 #' @param component An R object, function, or string.
+#' @param page The name of the page to add the component or sidebar to.
 #' @param copy Whether or not to copy images to \code{dashboard@datadir}.
 #' @param ... Additional parameters passed to the components render function. In case of an image, parameters \code{height} and \code{width} can be used to define the dimensions of the image with CSS or provide an alternative text with \code{image_alt_text}.
 #'
@@ -97,7 +97,7 @@ setMethod("add_component",
 
 #' @rdname i2dashboard-content
 setMethod("add_component",
-          signature = signature(dashboard = "i2dashboard", component = "knitr_kable"),
+          signature = signature(dashboard = "i2dashboard", component = "kableExtra"),
           definition = function(dashboard, component, page = "default", ...) {
             add_vis_object(dashboard, component, "kableExtra", page, ...) })
 
@@ -196,20 +196,23 @@ render_text <- function(file, title = NULL, raw = FALSE) {
 #' @param raw Whether or not to emit solely the markdown image code.
 #' @param width Width defined with CSS in the HTML img-tag.
 #' @param height Height defined with CSS in the HTML img-tag.
+#' @param in_component Whether the image belongs to a component or the sidebar
 #'
 #' @return A character string containing the evaluated component
-render_image <- function(image, image_alt_text = NULL, title = NULL, raw = FALSE, width = "100%", height = "auto") {
+render_image <- function(image, image_alt_text = NULL, title = NULL, raw = FALSE, width = "100%", height = "auto", in_component=TRUE) {
   if(is.null(image_alt_text)) {
     image_alt_text <- image
   }
-
-  content <- glue::glue(as.character(
-    htmltools::img(
-      src = image,
-      alt = image_alt_text,
-      style = paste0('height:', height, ';width:', width)
-    )),as.character(htmltools::br()))
-
+  if(in_component){
+    content <- glue::glue("![{image_alt_text}]({image})\n", image_alt_text = image_alt_text, image = image)
+  } else {
+    content <- glue::glue(as.character(
+      htmltools::img(
+        src = image,
+        alt = image_alt_text,
+        style = paste0('height:', height, ';width:', width)
+      )),as.character(htmltools::br()))
+  }
   if(raw) return(content)
   knitr::knit_expand(file = system.file("templates", "component.Rmd", package = "i2dash"),
                      delim = c("<%", "%>"),

R/get_set.R

@@ -51,13 +51,13 @@ setMethod("datadir<-", "i2dashboard", function(dashboard, value) {
 })
 
 #' @rdname i2dashboard-methods
-setMethod("social_links", "i2dashboard", function(dashboard) dashboard@social_links)
+setMethod("share", "i2dashboard", function(dashboard) dashboard@share)
 
 #' @rdname i2dashboard-methods
-setMethod("social_links<-", "i2dashboard", function(dashboard, value) {
+setMethod("share<-", "i2dashboard", function(dashboard, value) {
   i <- intersect(tolower(value), c("facebook", "twitter", "google-plus", "linkedin", "pinterest", "menu"))
   if (length(i) > 0) {
-    dashboard@social <- i
+    dashboard@share <- i
   }
   dashboard
 })

R/i2dashboard.R

@@ -28,7 +28,7 @@ NULL
 #' @slot sidebar Content of the global sidebar
 #' @slot colormaps A named list with color mappings.
 #' @slot source Either a logical value describing whether the source code should be embeded through an item in the navigation bar or a link to a URL where the source code can be found online.
-#' @slot social A vector with any number of the following services: “facebook”, “twitter”, “google-plus”, “linkedin”, and “pinterest”. You can also specify “menu” to provide a generic sharing drop-down menu that includes all of the services.
+#' @slot share A vector with any number of the following services: “facebook”, “twitter”, “google-plus”, “linkedin”, and “pinterest”. You can also specify “menu” to provide a generic sharing drop-down menu that includes all of the services.
 #' @slot navbar A list of links in the navigation bar (see the \href{https://rmarkdown.rstudio.com/flexdashboard/using.html#navigation_bar}{documentation of flexdashboard}).
 #'
 #' @return An \linkS4class{i2dashboard} object.
@@ -47,7 +47,7 @@ setClass("i2dashboard",
     sidebar = "character",
     colormaps = "list",
     source = "character",
-    social = "character",
+    share = "character",
     navbar = "list"
     ),
   prototype=list(
@@ -57,7 +57,7 @@ setClass("i2dashboard",
     datadir = file.path(getwd(), "report-data"),
     pages = list(default = list(title = "Default page", layout = "default", menu = NULL, components = list(), sidebar = NULL, max_components = Inf)),
     source = "",
-    social = ""
+    share = ""
     )
   )
 

R/sidebar.R

@@ -20,7 +20,7 @@ setMethod("add_to_sidebar",
 
             component <- switch(mode,
                                 "text" = render_text(component, ...),
-                                "image" = render_image(component, ...))
+                                "image" = render_image(component, in_component=FALSE, ...))
 
             if(global) {
               dashboard@sidebar <- paste0(dashboard@sidebar, component)

man/i2dashboard-class.Rd

@@ -50,7 +50,7 @@ The \linkS4class{i2dashboard} S4 class provides main functionality of the packag
 
 \item{\code{source}}{Either a logical value describing whether the source code should be embeded through an item in the navigation bar or a link to a URL where the source code can be found online.}
 
-\item{\code{social}}{A vector with any number of the following services: “facebook”, “twitter”, “google-plus”, “linkedin”, and “pinterest”. You can also specify “menu” to provide a generic sharing drop-down menu that includes all of the services.}
+\item{\code{share}}{A vector with any number of the following services: “facebook”, “twitter”, “google-plus”, “linkedin”, and “pinterest”. You can also specify “menu” to provide a generic sharing drop-down menu that includes all of the services.}
 
 \item{\code{navbar}}{A list of links in the navigation bar (see the \href{https://rmarkdown.rstudio.com/flexdashboard/using.html#navigation_bar}{documentation of flexdashboard}).}
 }}

man/i2dashboard-content.Rd

@@ -10,7 +10,7 @@
 \alias{add_component,i2dashboard,function-method}
 \alias{add_component,i2dashboard,gg-method}
 \alias{add_component,i2dashboard,gt_tbl-method}
-\alias{add_component,i2dashboard,knitr_kable-method}
+\alias{add_component,i2dashboard,kableExtra-method}
 \alias{add_component,i2dashboard,Heatmap-method}
 \alias{add_component,i2dashboard,ANY-method}
 \alias{add_link,i2dashboard-method}
@@ -35,7 +35,7 @@ add_link(dashboard, ...)
 
 \S4method{add_component}{i2dashboard,gt_tbl}(dashboard, component, page = "default", ...)
 
-\S4method{add_component}{i2dashboard,knitr_kable}(dashboard, component, page = "default", ...)
+\S4method{add_component}{i2dashboard,kableExtra}(dashboard, component, page = "default", ...)
 
 \S4method{add_component}{i2dashboard,Heatmap}(dashboard, component, page = "default", ...)
 

man/i2dashboard-methods.Rd

@@ -11,8 +11,8 @@
 \alias{theme<-}
 \alias{datadir}
 \alias{datadir<-}
-\alias{social_links}
-\alias{social_links<-}
+\alias{share}
+\alias{share<-}
 \alias{embed_source<-}
 \alias{source}
 \alias{source<-}
@@ -26,8 +26,8 @@
 \alias{theme<-,i2dashboard-method}
 \alias{datadir,i2dashboard-method}
 \alias{datadir<-,i2dashboard-method}
-\alias{social_links,i2dashboard-method}
-\alias{social_links<-,i2dashboard-method}
+\alias{share,i2dashboard-method}
+\alias{share<-,i2dashboard-method}
 \alias{source,i2dashboard-method}
 \alias{source<-,i2dashboard-method}
 \alias{embed_source<-,i2dashboard-method}
@@ -53,9 +53,9 @@ datadir(dashboard)
 
 datadir(dashboard) <- value
 
-social_links(dashboard)
+share(dashboard)
 
-social_links(dashboard) <- value
+share(dashboard) <- value
 
 embed_source(dashboard) <- value
 
@@ -83,9 +83,9 @@ source(dashboard) <- value
 
 \S4method{datadir}{i2dashboard}(dashboard) <- value
 
-\S4method{social_links}{i2dashboard}(dashboard)
+\S4method{share}{i2dashboard}(dashboard)
 
-\S4method{social_links}{i2dashboard}(dashboard) <- value
+\S4method{share}{i2dashboard}(dashboard) <- value
 
 \S4method{source}{i2dashboard}(dashboard)
 

man/render_image.Rd

@@ -10,7 +10,8 @@ render_image(
   title = NULL,
   raw = FALSE,
   width = "100\%",
-  height = "auto"
+  height = "auto",
+  in_component = TRUE
 )
 }
 \arguments{
@@ -25,6 +26,8 @@ render_image(
 \item{width}{Width defined with CSS in the HTML img-tag.}
 
 \item{height}{Height defined with CSS in the HTML img-tag.}
+
+\item{in_component}{Whether the image belongs to a component or the sidebar}
 }
 \value{
 A character string containing the evaluated component

tests/testthat.R

+library(magrittr)
+library(testthat)
+library(i2dash)
+
+test_check("i2dash")

tests/testthat/input-data/i2dashboard.Rmd

+---
+author: []
+title: i2dashboard
+output:
+  flexdashboard::flex_dashboard:
+    theme: yeti
+    social: null
+    source: null
+    navbar: []
+---
+
+```{r i2dash-global-setup}
+# Deal with operation within a switchr environment
+if (any(grepl(pattern = ".switchr", x = .libPaths()))) {
+  switchr::switchrNoUnload(TRUE)
+}
+
+# Make it possible to reuse chunk labels
+options(knitr.duplicate.label = "allow")
+
+# Set datadir variable, components should fetch their env from here!
+datadir <- "input-data"
+
+# Set up color mappings
+colormaps <- list()
+```
+
+Default page 
+====================================================
+
+
+
+Column {.tabset}
+----------------------------------------------------
+
+
+

tests/testthat/input-data/sample.txt

+Lorem ipsum dolor sit amet

tests/testthat/test-accessor-methods.R

+context("Accessor methods")
+
+test_that("general getter and setter methods work correctly",{
+  t <- "Test string"
+  i <- TRUE
+  s <- "menu"
+
+  dashboard <- i2dashboard()
+  title(dashboard) <- t
+  expect_equal(title(dashboard), t)
+
+  author(dashboard) <- t
+  expect_equal(author(dashboard), t)
+
+  theme(dashboard) <- t
+  expect_equal(theme(dashboard), t)
+
+  datadir(dashboard) <- t
+  expect_equal(datadir(dashboard), t)
+
+  interactivity(dashboard) <- i
+  expect_equal(interactivity(dashboard), i)
+})
+
+test_that("getting/setting the source code embedding works as expected", {
+  dashboard <- i2dashboard()
+
+  embed_source(dashboard) <- TRUE
+  expect_equal(source(dashboard), "embed")
+
+  source(dashboard) <- "http://url.ending"
+  expect_equal(source(dashboard), "http://url.ending")
+
+  embed_source(dashboard) <- FALSE
+  expect_equal(source(dashboard), "")
+})
+
+test_that("getting/setting the share links for social media work as expected", {
+  dashboard <- i2dashboard()
+
+  share(dashboard) <- c("Facebook", "reddit")
+  expect_equal(share(dashboard), c("facebook"))
+})

tests/testthat/test-add-content.R

+context("Adding content to the dashboard")
+
+#
+# add_link
+#
+test_that("adding a link to the navigation works as expected",{
+  l1 <- list(href = "sample_url", title = "Link", icon = "", align = "right", target = "")
+
+  i2dashboard() %>%
+    add_link(
+      href = "sample_url",
+      title = "Link") -> dashboard
+
+  expect_s4_class(dashboard, "i2dashboard")
+  expect_equal(dashboard@navbar[[1]], l1)
+  expect_warning(add_link(dashboard, href = "sample_url"), "Both, title and icon, cannot be NULL when adding a link.")
+})
+
+#
+# add_colormap
+#
+test_that("adding a colorbar to the dashboard works as expected",{
+  colors <- c("l1" = "#F7FCFD", "l2" ="#E5F5F9", "l3" = "#CCECE6")
+
+  i2dashboard() %>%
+    add_colormap(map = colors, name = "test") -> dashboard
+
+  expect_s4_class(dashboard, "i2dashboard")
+  expect_equal(dashboard@colormaps$test, colors)
+})
+
+#
+# add_to_sidebar
+#
+test_that("adding sidebar content to the dashboard works as expected",{
+  text_generator <- function(dashboard) paste0("Lorem ipsum dolor sit amet\n")
+  base_sidebar <- function(component, global=F) i2dashboard() %>% add_to_sidebar(component = component, global=global) -> dashboard
+
+  # add text to local sidebar
+  expect_s4_class(base_sidebar("input-data/sample.txt"), "i2dashboard")
+  expect_equal(base_sidebar("input-data/sample.txt")@pages$default$sidebar, "### \n\nLorem ipsum dolor sit amet\n")
+
+  # add image to local sidebar
+  expect_s4_class(base_sidebar("input-data/sample.jpg"), "i2dashboard")
+  expect_equal(base_sidebar("input-data/sample.jpg")@pages$default$sidebar, "### \n\n<img src=\"input-data/sample.jpg\" alt=\"input-data/sample.jpg\" style=\"height:auto;width:100%\"/><br/>\n")
+
+  # use function for local sidebar
+  expect_s4_class(base_sidebar(text_generator), "i2dashboard")
+  expect_equal(base_sidebar(text_generator)@pages$default$sidebar, "Lorem ipsum dolor sit amet\n")
+
+  # add text to global sidebar
+  expect_s4_class(base_sidebar("input-data/sample.txt", global=TRUE), "i2dashboard")
+  expect_equal(base_sidebar("input-data/sample.txt", global=TRUE)@sidebar, "### \n\nLorem ipsum dolor sit amet\n")
+
+  # add image to global sidebar
+  expect_s4_class(base_sidebar("input-data/sample.jpg", global=TRUE), "i2dashboard")
+  expect_equal(base_sidebar("input-data/sample.jpg", global=TRUE)@sidebar, "### \n\n<img src=\"input-data/sample.jpg\" alt=\"input-data/sample.jpg\" style=\"height:auto;width:100%\"/><br/>\n")
+
+  # use function for global sidebar
+  expect_s4_class(base_sidebar(text_generator, global=TRUE), "i2dashboard")
+  expect_equal(base_sidebar(text_generator, global=TRUE)@sidebar, "Lorem ipsum dolor sit amet\n")
+
+  expect_warning(i2dashboard() %>% add_to_sidebar(component = "input-data/sample.txt", page = "page1"), "i2dashboard dashboard does not contain a page named 'page1'")
+})
+
+#
+# add_component
+#
+test_that("adding components to a dashboard is correct",{
+
+
+  # test signature 'i2dashboard,'function''
+  text_generator <- function(dashboard) paste0("### Test\n\n", "Lorem ipsum dolor sit amet\n")
+  i2dashboard() %>%
+    add_component(component = text_generator) -> dashboard
+  expect_equal(length(dashboard@pages$default$components), 1)
+  expect_equal(dashboard@pages$default$components[[1]], "### Test\n\nLorem ipsum dolor sit amet\n")
+
+  base_component <- function(component) i2dashboard() %>% add_component(component = component, title = "Test") -> dashboard
+
+  # test signature 'i2dashboard,character'
+  expect_equal(length(base_component("input-data/sample.txt")@pages$default$components), 1)
+  expect_equal(base_component("input-data/sample.txt")@pages$default$components[[1]], "### Test\n\nLorem ipsum dolor sit amet\n")
+
+  expect_equal(length(base_component("input-data/sample.jpg")@pages$default$components), 1)
+  expect_equal(base_component("input-data/sample.jpg")@pages$default$components[[1]], "### Test\n\n![input-data/sample.jpg](input-data/sample.jpg)\n")
+
+  # test signature 'i2dashboard,gg'
+  if(requireNamespace("ggplot2", quietly = TRUE)){
+    o1 <- ggplot2::ggplot(mtcars,ggplot2::aes(x=wt,y=mpg)) + ggplot2::geom_point()
+
+    expect_equal(length(base_component(o1)@pages$default$components), 1)
+    expect_match(base_component(o1)@pages$default$components[[1]], "### Test")
+  }
+
+  # test signature 'i2dashboard,gt_tbl'
+  if(requireNamespace("gt", quietly = TRUE)){
+    o2 <- gt::gt(mtcars)
+
+    expect_equal(length(base_component(o2)@pages$default$components), 1)
+    expect_match(base_component(o2)@pages$default$components[[1]], "### Test")
+  }
+  # test signature 'i2dashboard,knitr_kable'
+  if(requireNamespace("kableExtra", quietly = TRUE)){
+    o3 <- kableExtra::kable(mtcars) %>% kableExtra::kable_styling()
+
+    expect_equal(length(base_component(o3)@pages$default$components), 1)
+    expect_match(base_component(o3)@pages$default$components[[1]], "### Test")
+  }
+
+  # test signature 'i2dashboard,Heatmap'
+  if(requireNamespace("ComplexHeatmap", quietly = TRUE)) {
+    o4 <- ComplexHeatmap::Heatmap(scale(mtcars))
+
+    expect_equal(length(base_component(o4)@pages$default$components), 1)
+    expect_match(base_component(o4)@pages$default$components[[1]], "### Test")
+  }
+
+  # test signature 'i2dashboard,ANY'
+  if(requireNamespace("plotly", quietly = TRUE)) {
+    o5 <- plotly::plot_ly(mtcars,x=~wt,y=~mpg)
+    #o6 <- lattice::xyplot(mpg ~ hp, data=mtcars)
+
+    expect_equal(length(base_component(o5)@pages$default$components), 1)
+    expect_match(base_component(o5)@pages$default$components[[1]], "### Test")
+  }
+  expect_warning(add_component(dashboard, component = text_generator, page = "page1"), "i2dashboard dashboard does not contain a page named 'page1'")
+  #expect_warning(add_component(dashboard, component = o6), "The component did not inherit from any of the currently supported classes ('htmlwidget').")
+
+  unlink(dashboard@datadir, recursive=TRUE)
+})

tests/testthat/test-assemble.R

+context("Assemble dashboard")
+
+test_that("Assembling dashboard is correct",{
+  i2dashboard(datadir="input-data") %>%
+    assemble() -> dashboard
+
+  expect_s4_class(dashboard, "i2dashboard")
+
+  # removing comment line containing the sys.time for generating correct hash value
+  rmd <- readLines(dashboard@file)
+  new_rmd <- rmd[-31]
+  writeLines(new_rmd, dashboard@file)
+
+  test_hash <- digest::digest(file = dashboard@file, serialize = F, seed = 100)
+  ref_hash <- digest::digest(file = "input-data/i2dashboard.Rmd", serialize = F, seed = 100)
+  expect_equal(test_hash, ref_hash)
+
+  expect_warning(assemble(dashboard, pages = "page1"), "i2dashboard dashboard does not contain a page named 'page1'")
+
+  # Delete dashboard Rmd file
+  if (file.exists(dashboard@file)) {
+    file.remove(dashboard@file)
+  }
+})

tests/testthat/test-i2dashboard-class.R

+context("i2dashboard class")
+
+test_that("construction of the i2dashboard works correctly",{
+  dashboard <- i2dashboard()
+  expect_s4_class(dashboard, "i2dashboard")
+})
+
+test_that("show function works",{
+  dashboard <- i2dashboard()
+  expect_output(show(dashboard),
+"A flexdashboard with the title: i2dashboard
+... containing  1 pages:
+ ... the page 'default' with the title 'Default page' contains 0 components.")
+  unlink(dashboard@datadir, recursive=TRUE)
+})