Add fill arguments to shinyWidgetOutput() and sizingPolicy()

ramnathv · Oct 21, 2022 · cc6504a · cc6504a
1 parent 9827b5f
commit cc6504a
Show file tree

Hide file tree

Showing 7 changed files with 132 additions and 154 deletions.
diff --git a/.github/workflows/R-CMD-check.yaml b/.github/workflows/R-CMD-check.yaml
@@ -1,16 +1,14 @@
-# NOTE: This workflow is overkill for most R packages
-# check-standard.yaml is likely a better choice
-# usethis::use_github_action("check-standard") will install it.
+# Workflow derived from https://github.com/r-lib/actions/tree/v2/examples
+# Need help debugging build failures? Start at https://github.com/r-lib/actions#where-to-find-help
 #
-# For help debugging build failures open an issue on the RStudio community with the 'github-actions' tag.
-# https://community.rstudio.com/new-topic?category=Package%20development&tags=github-actions
+# NOTE: This workflow is overkill for most R packages and
+# check-standard.yaml is likely a better choice.
+# usethis::use_github_action("check-standard") will install it.
 on:
   push:
-    branches:
-      - master
+    branches: [main, master]
   pull_request:
-    branches:
-      - master
+    branches: [main, master]
 
 name: R-CMD-check
 
@@ -26,79 +24,33 @@ jobs:
         config:
           - {os: macOS-latest,   r: 'release'}
           - {os: windows-latest, r: 'release'}
-          - {os: windows-latest, r: '3.6'}
-          - {os: ubuntu-16.04,   r: 'devel', rspm: "https://packagemanager.rstudio.com/cran/__linux__/xenial/latest", http-user-agent: "R/4.0.0 (ubuntu-16.04) R (4.0.0 x86_64-pc-linux-gnu x86_64 linux-gnu) on GitHub Actions" }
-          - {os: ubuntu-16.04,   r: 'release', rspm: "https://packagemanager.rstudio.com/cran/__linux__/xenial/latest"}
-          - {os: ubuntu-16.04,   r: 'oldrel',  rspm: "https://packagemanager.rstudio.com/cran/__linux__/xenial/latest"}
-          - {os: ubuntu-16.04,   r: '3.5',     rspm: "https://packagemanager.rstudio.com/cran/__linux__/xenial/latest"}
-          - {os: ubuntu-16.04,   r: '3.4',     rspm: "https://packagemanager.rstudio.com/cran/__linux__/xenial/latest"}
-          - {os: ubuntu-16.04,   r: '3.3',     rspm: "https://packagemanager.rstudio.com/cran/__linux__/xenial/latest"}
+          - {os: ubuntu-latest,   r: 'devel', http-user-agent: 'release'}
+          - {os: ubuntu-latest,   r: 'release'}
+          - {os: ubuntu-latest,   r: 'oldrel-1'}
+          - {os: ubuntu-latest,   r: 'oldrel-2'}
+          - {os: ubuntu-latest,   r: 'oldrel-3'}
+          - {os: ubuntu-latest,   r: 'oldrel-4'}
 
     env:
-      R_REMOTES_NO_ERRORS_FROM_WARNINGS: true
-      RSPM: ${{ matrix.config.rspm }}
       GITHUB_PAT: ${{ secrets.GITHUB_TOKEN }}
+      R_KEEP_PKG_SOURCE: yes
 
     steps:
       - uses: actions/checkout@v2
 
-      - uses: r-lib/actions/setup-r@master
+      - uses: r-lib/actions/setup-pandoc@v2
+
+      - uses: r-lib/actions/setup-r@v2
         with:
           r-version: ${{ matrix.config.r }}
           http-user-agent: ${{ matrix.config.http-user-agent }}
+          use-public-rspm: true
 
-      - uses: r-lib/actions/setup-pandoc@master
-
-      - name: Query dependencies
-        run: |
-          install.packages('remotes')
-          saveRDS(remotes::dev_package_deps(dependencies = TRUE), ".github/depends.Rds", version = 2)
-          writeLines(sprintf("R-%i.%i", getRversion()$major, getRversion()$minor), ".github/R-version")
-        shell: Rscript {0}
-
-      - name: Cache R packages
-        if: runner.os != 'Windows'
-        uses: actions/cache@v2
+      - uses: r-lib/actions/setup-r-dependencies@v2
         with:
-          path: ${{ env.R_LIBS_USER }}
-          key: ${{ runner.os }}-${{ hashFiles('.github/R-version') }}-1-${{ hashFiles('.github/depends.Rds') }}
-          restore-keys: ${{ runner.os }}-${{ hashFiles('.github/R-version') }}-1-
-
-      - name: Install system dependencies
-        if: runner.os == 'Linux'
-        run: |
-          while read -r cmd
-          do
-            eval sudo $cmd
-          done < <(Rscript -e 'writeLines(remotes::system_requirements("ubuntu", "16.04"))')
-
-      - name: Install dependencies
-        run: |
-          remotes::install_deps(dependencies = TRUE)
-          remotes::install_cran("rcmdcheck")
-        shell: Rscript {0}
-
-      - name: Session info
-        run: |
-          options(width = 100)
-          pkgs <- installed.packages()[, "Package"]
-          sessioninfo::session_info(pkgs, include_base = TRUE)
-        shell: Rscript {0}
-
-      - name: Check
-        env:
-          _R_CHECK_CRAN_INCOMING_: false
-        run: rcmdcheck::rcmdcheck(args = c("--no-manual", "--as-cran"), error_on = "warning", check_dir = "check")
-        shell: Rscript {0}
-
-      - name: Show testthat output
-        if: always()
-        run: find check -name 'testthat.Rout*' -exec cat '{}' \; || true
-        shell: bash
+          extra-packages: any::rcmdcheck
+          needs: check
 
-      - name: Upload check results
-        if: failure()
-        uses: actions/upload-artifact@main
+      - uses: r-lib/actions/check-r-package@v2
         with:
-          name: ${{ runner.os }}-r${{ matrix.config.r }}-results
-          path: check
+          upload-snapshots: true
diff --git a/DESCRIPTION b/DESCRIPTION
@@ -1,7 +1,7 @@
 Package: htmlwidgets
 Type: Package
 Title: HTML Widgets for R
-Version: 1.5.4.9000
+Version: 1.5.4.9001
 Authors@R: c(
     person("Ramnath", "Vaidyanathan", role = c("aut", "cph")),
     person("Yihui", "Xie", role = c("aut")),
@@ -19,7 +19,7 @@ License: MIT + file LICENSE
 VignetteBuilder: knitr
 Imports:
     grDevices,
-    htmltools (>= 0.3),
+    htmltools (>= 0.5.3.9001),
     jsonlite (>= 0.9.16),
     yaml
 Suggests:
@@ -30,3 +30,6 @@ Enhances: shiny (>= 1.1)
 URL: https://github.com/ramnathv/htmlwidgets
 BugReports: https://github.com/ramnathv/htmlwidgets/issues
 RoxygenNote: 7.2.1
+Encoding: UTF-8
+Remotes:
+    rstudio/htmltools
diff --git a/NEWS.md b/NEWS.md
@@ -3,10 +3,12 @@ htmlwidgets 1.5.4.9000
 
 ### Breaking change
 
-* `shinyWidgetOutput()`'s `reportSize` argument now defaults to `TRUE`. This way, calling `shiny::getCurrentOutputInfo()` inside a `shinyRenderWidget()` context will report the current height and width of the widget. 
+* `shinyWidgetOutput()`'s `reportSize` argument now defaults to `TRUE`. This way, calling `shiny::getCurrentOutputInfo()` inside a `shinyRenderWidget()` context will report the current height and width of the widget.
+* `shinyWidgetOutput()` (and `as.tags.htmlwidget()`) no longer unnecessarily wraps the return value in an additional `tagList()`. (#442)
 
 ### Improvements
 
+* `shinyWidgetOutput()` and `sizingPolicy()` both gain a new `fill` parameter. When `TRUE`, the widget is allowed to grow/shrink to fit it's parent container so long as that parent has a defined height and has been marked with `htmltools::asFillContainer()` (https://github.com/rstudio/htmltools/pull/343). The primary motivation for this is to allow widgets to grow and shrink (by default) when used [inside `bslib::card_body_fill()`](https://rstudio.github.io/bslib/articles/cards.html#responsive-sizing) (#442)
 * Closed #433: `saveWidget()` no longer throw deprecation warning when pandoc 2.19 or higher is used.
 
 htmlwidgets 1.5.4

diff --git a/R/htmlwidgets.R b/R/htmlwidgets.R
@@ -170,62 +170,53 @@ addHook <- function(x, hookName, jsCode, data = NULL) {
 
 toHTML <- function(x, standalone = FALSE, knitrOptions = NULL) {
 
+  x$id <- x$elementId %||% paste("htmlwidget", createWidgetId(), sep = "-")
+
   sizeInfo <- resolveSizing(x, x$sizingPolicy, standalone = standalone, knitrOptions = knitrOptions)
 
-  if (!is.null(x$elementId))
-    id <- x$elementId
-  else
-    id <- paste("htmlwidget", createWidgetId(), sep="-")
+  name <- class(x)[1]
+  package <- attr(x, "package")
 
-  w <- validateCssUnit(sizeInfo$width)
-  h <- validateCssUnit(sizeInfo$height)
+  html <- widget_html(
+    name, package, id = x$id,
+    style = css(
+      width = validateCssUnit(sizeInfo$width),
+      height = validateCssUnit(sizeInfo$height)
+    ),
+    class = paste(name, "html-widget"),
+    width = sizeInfo$width,
+    height = sizeInfo$height
+  )
 
-  # create a style attribute for the width and height
-  style <- paste(
-    "width:", w, ";",
-    "height:", h, ";",
-    sep = "")
+  if (sizeInfo$fill) {
+    html <- asFillItem(html)
+  }
 
-  x$id <- id
+  if (!is.null(x$prepend) || !is.null(x$append)) {
+    html <- tagList(x$append, html, x$prepend)
+  }
 
-  container <- if (isTRUE(standalone)) {
-    function(x) {
-      div(id="htmlwidget_container", x)
-    }
-  } else {
-    identity
+  if (isTRUE(standalone)) {
+    html <- div(id = "htmlwidget_container", html)
   }
 
-  html <- htmltools::tagList(
-    container(
-      htmltools::tagList(
-        x$prepend,
-        widget_html(
-          name = class(x)[1],
-          package = attr(x, "package"),
-          id = id,
-          style = style,
-          class = paste(class(x)[1], "html-widget"),
-          width = sizeInfo$width,
-          height = sizeInfo$height
-        ),
-        x$append
-      )
-    ),
-    widget_data(x, id),
+  html <- tagList(
+    html, widget_data(x, x$id),
     if (!is.null(sizeInfo$runtime)) {
-      tags$script(type="application/htmlwidget-sizing", `data-for` = id,
+      tags$script(
+        type = "application/htmlwidget-sizing",
+        `data-for` = x$id,
         toJSON(sizeInfo$runtime)
       )
     }
   )
-  html <- htmltools::attachDependencies(html,
-    c(widget_dependencies(class(x)[1], attr(x, 'package')),
-      x$dependencies)
-  )
 
-  htmltools::browsable(html)
+  deps <- c(
+    widget_dependencies(name, package),
+    x$dependencies
+  )
 
+  browsable(attachDependencies(html, deps, append = TRUE))
 }
 
 lookup_func <- function(name, package) {
@@ -263,7 +254,7 @@ lookup_widget_html_method <- function(name, package) {
   list(fn = widget_html.default, name = "widget_html.default", legacy = FALSE)
 }
 
-widget_html <- function (name, package, id, style, class, inline = FALSE, ...) {
+widget_html <- function(name, package, id, style, class, inline = FALSE, ...) {
 
   fn_info <- lookup_widget_html_method(name, package)
 
@@ -451,6 +442,10 @@ createWidget <- function(name,
 #'   is useful if you want to save an expression in a variable.
 #' @param cacheHint Extra information to use for optional caching using
 #'   \code{shiny::bindCache()}.
+#' @param fill whether or not the returned tag should be wrapped
+#'   [htmltools::asFillItem()] so that it's `height` is allowed to grow/shrink
+#'   inside a tag wrapped with [htmltools::asFillContainer()] (e.g.,
+#'   [bslib::card_body_fill()]).
 #'
 #' @return An output or render function that enables the use of the widget
 #'   within Shiny applications.
@@ -474,34 +469,36 @@ createWidget <- function(name,
 #'
 #' @export
 shinyWidgetOutput <- function(outputId, name, width, height, package = name,
-                              inline = FALSE, reportSize = TRUE, reportTheme = FALSE) {
+                              inline = FALSE, reportSize = TRUE, reportTheme = FALSE,
+                              fill = TRUE) {
 
   # Theme reporting requires this shiny feature
   # https://github.com/rstudio/shiny/pull/2740/files
   if (reportTheme && !is_installed("shiny", "1.4.0.9003")) {
     message("`reportTheme = TRUE` requires shiny v.1.4.0.9003 or higher. Consider upgrading shiny.")
   }
 
-  # generate html
-  html <- htmltools::tagList(
-    widget_html(
-      name, package, id = outputId,
-      class = paste0(
-        name, " html-widget html-widget-output",
-        if (reportSize) " shiny-report-size",
-        if (reportTheme) " shiny-report-theme"
-      ),
-      style = sprintf("width:%s; height:%s; %s",
-        htmltools::validateCssUnit(width),
-        htmltools::validateCssUnit(height),
-        if (inline) "display: inline-block;" else ""
-      ), width = width, height = height
+  tag <- widget_html(
+    name, package, id = outputId,
+    class = paste0(
+      name, " html-widget html-widget-output",
+      if (reportSize) " shiny-report-size",
+      if (reportTheme) " shiny-report-theme"
+    ),
+    style = css(
+      width = validateCssUnit(width),
+      height = validateCssUnit(height),
+      display = if (inline) "inline-block"
     )
   )
 
-  # attach dependencies
-  dependencies = widget_dependencies(name, package)
-  htmltools::attachDependencies(html, dependencies)
+  if (fill) {
+    tag <- asFillItem(tag)
+  }
+
+  attachDependencies(
+    tag, widget_dependencies(name, package), append = TRUE
+  )
 }