Merge f747105 into bbe6dc3

.Rbuildignore

@@ -7,3 +7,4 @@
 ^_pkgdown\.yml$
 ^docs$
 ^pkgdown$
+^codecov\.yml$

.github/workflows/R-CMD-check.yaml

@@ -18,7 +18,7 @@ jobs:
       fail-fast: false
       matrix:
         config:
-          - {os: macOS-latest,   r: '4.0.1'  }
+          - {os: macOS-latest,   r: '4.0.1',  coveralls: "true"  }
           - {os: windows-latest, r: '4.0.1', }
           - {os: ubuntu-18.04,   r: '4.0.1',  rspm: "https://packagemanager.rstudio.com/all/__linux__/bionic/latest"}
 
@@ -41,14 +41,30 @@ jobs:
       - uses: r-lib/actions/setup-r-dependencies@v2
         with:
           cache-version: 2
-          extra-packages: any::rcmdcheck
-          needs: check
+          extra-packages: any::rcmdcheck, any::covr
 
       - uses: r-lib/actions/check-r-package@v2
         with:
           upload-snapshots: true
 
-      # - name: Show testthat output
-      #   if: always()
-      #   run: find check -name 'testthat.Rout*' -exec cat '{}' \; || true
-      #   shell: bash
+      - name: Show testthat output
+        if: always()
+        run: find check -name 'testthat.Rout*' -exec cat '{}' \; || true
+        shell: bash
+
+      - name: Upload check results
+        if: failure()
+        uses: actions/upload-artifact@main
+        with:
+          name: ${{ runner.os }}-r${{ matrix.config.r }}-results
+          path: check
+
+      - name: Test coverage
+        if: matrix.config.coveralls == 'true'
+        continue-on-error: true
+        run: |
+          covr::coveralls(
+            function_exclusions = "\\.onLoad",
+            repo_token = "${{ secrets.COVERALLS_TOKEN }}",
+            service_name='drone')
+        shell: Rscript {0}

.github/workflows/pkgdown.yaml

@@ -14,6 +14,7 @@ jobs:
     runs-on: macOS-latest
     env:
       GITHUB_PAT: ${{ secrets.GITHUB_TOKEN }}
+
     steps:
       - uses: actions/checkout@v2
 

.github/workflows/pr-ci.yaml → .github/workflows/style-pr.yaml

@@ -27,25 +27,33 @@ jobs:
       - name: Install dependencies
         run: Rscript -e 'install.packages("styler")'
 
-      - name: save R.cache location
-        id: save-r-cache-location
+      - name: Enable styler cache
+        run: styler::cache_activate()
+        shell: Rscript {0}
+
+      - name: Determine cache location
+        id: styler-location
         run: |
-          cat("##[set-output name=r-cache-location;]", R.cache::getCacheRootPath(), "\n", sep = "")
+          cat(
+            "##[set-output name=location;]",
+            styler::cache_info(format = "tabular")$location,
+            "\n",
+            sep = ""
+          )
         shell: Rscript {0}
 
-      - name: R.cache cache
+      - name: Cache styler
         uses: actions/cache@v2
-        env:
-          cache-name: r-cache
         with:
-          path: ${{ r-cache-location }}
-          key: ${{ runner.os }}-${{ env.cache-name }}-${{ github.sha }}
+          path: ${{ steps.styler-location.outputs.location }}
+          key: ${{ runner.os }}-styler-${{ github.sha }}
           restore-keys: |
-            ${{ runner.os }}-${{ env.cache-name }}-
+            ${{ runner.os }}-styler-
             ${{ runner.os }}-
 
       - name: Style
-        run: Rscript -e 'styler::style_pkg()'
+        run: styler::style_pkg(filetype = c(".R"))
+        shell: Rscript {0}
 
       - name: commit
         run: |

DESCRIPTION

@@ -34,8 +34,12 @@ Imports:
     purrr
 Remotes: Sage-Bionetworks/sagethemes
 Suggests: 
+    covr,
     knitr,
-    rmarkdown
+    rmarkdown,
+    testthat (>= 3.0.0)
 VignetteBuilder: knitr
-URL: https://github.com/Sage-Bionetworks/dcamodules
+URL: https://sage-bionetworks.github.io/dcamodules/,
+    https://github.com/Sage-Bionetworks/dcamodules
 BugReports: https://github.com/Sage-Bionetworks/dcamodules/issues
+Config/testthat/edition: 3

NAMESPACE

@@ -32,7 +32,6 @@ importFrom(sass,sass)
 importFrom(sass,sass_file)
 importFrom(sass,sass_layer)
 importFrom(sass,sass_options)
-importFrom(shiny,selectInput)
 importFrom(shinydashboard,updateTabItems)
 importFrom(tools,file_ext)
 importFrom(utils,packageVersion)

R/dca_footer.R

@@ -18,6 +18,8 @@
 #' @rdname dcaFooter
 #' @export
 dcaFooter <- function(message, media = NULL, height = "100px", ...) {
+
+  height <- validateCssUnit(height)
   tags$div(
     class = "dca-footer-placeholder",
     style = sprintf("height: %s;", height),

R/utils.R

@@ -35,7 +35,7 @@ get_tab_names <- function(.tab) {
 #' widgetUI <- function(id) {
 #'   ns <- NS(id)
 #'   items <- c("chicken", "egg")
-#'   var_to_server(ns("items"), tab_names)
+#'   var_to_server(ns("items"), items)
 #' }
 #'
 #' widgetServer <- function() {
@@ -50,9 +50,8 @@ get_tab_names <- function(.tab) {
 #' }
 #' @rdname var_to_server
 #' @export
-#' @importFrom shiny selectInput
 var_to_server <- function(id, values) {
-  out <- shiny::selectInput(id,
+  out <- selectInput(id,
     "",
     choices = values,
     selected = values,
@@ -82,9 +81,9 @@ insert_attribute <- function(.tag, pos = 1, ...) {
   if (pos == 0 || length(childrens) == 0) {
     .tag <- htmltools::tagAppendAttributes(.tag, ...)
   } else {
-    .tag$children[[pos]] <-
+    .tag$children[[1]][[pos]] <-
       htmltools::tagAppendAttributes(
-        .tag$children[[pos]],
+        .tag$children[[1]][[pos]],
         ...
       )
   }

README.md

@@ -5,7 +5,7 @@
 [![Lifecycle:
 experimental](https://img.shields.io/badge/lifecycle-experimental-orange.svg)](https://lifecycle.r-lib.org/articles/stages.html#experimental)
 [![R-CMD-check](https://github.com/Sage-Bionetworks/dcamodules/actions/workflows/R-CMD-check.yaml/badge.svg?branch=main)](https://github.com/Sage-Bionetworks/dcamodules/actions/workflows/R-CMD-check.yaml)
-
+[![Coveralls test coverage](https://coveralls.io/repos/github/Sage-Bionetworks/dcamodules/badge.svg)](https://coveralls.io/r/Sage-Bionetworks/dcamodules?branch=feature-add-tests)
 <!-- badges: end -->
 
 The goal of dcamodules is to collect essential modules used in the data

tests/testthat.R

@@ -0,0 +1,4 @@
+library(testthat)
+library(dcamodules)
+
+test_check("dcamodules")

tests/testthat/test-dca_buttons.R

@@ -0,0 +1,51 @@
+test_that("shinyButton works", {
+  btn <- shinyButton(
+    "test-id", "test-button",
+    style = "color: red;"
+  )
+
+  expect_identical(btn[[1]]$attribs$id, "test-id")
+  expect_identical(btn[[1]]$attribs$class, "btn btn-default action-button dca-shiny-btn")
+  expect_identical(btn[[1]]$attribs$style, "color: red;")
+  expect_identical(btn[[2]]$stylesheet, "main.min.css")
+})
+
+test_that("arrowButton works", {
+  btn <- arrowButton(
+    "test-id",
+    style = "color: red;"
+  )
+  expect_identical(btn[[1]]$attribs$id, "test-id")
+  expect_identical(
+    purrr::map_chr(btn[[1]]$children[[1]][[1]], ~ .x$attribs$class),
+    rep("fa fa-angle-left", 3)
+  )
+  expect_identical(btn[[1]]$attribs$class, "btn btn-default action-button dca-left-btn")
+  expect_identical(btn[[1]]$attribs$style, "color: red;")
+  expect_identical(btn[[2]]$stylesheet, "main.min.css")
+})
+
+test_that("mediaButton works", {
+  btn <- mediaButton(
+    "google",
+    style = "color: red;"
+  )
+
+  expect_true(grepl("fa-google", btn[[1]]$children[[1]]$attribs$class))
+  expect_true(is.null(btn[[1]]$attribs$link))
+  expect_identical(btn[[1]]$attribs$class, "dca-icon-btn")
+  expect_identical(btn[[1]]$attribs$style, "color: red;")
+  expect_identical(btn[[2]]$stylesheet, "main.min.css")
+})
+
+test_that("paletteButton works", {
+  btn <- paletteButton(
+    "test-id", "red",
+    style = "color: red;"
+  )
+  expect_identical(btn[[1]]$attribs$id, "test-id")
+  expect_identical(btn[[1]]$attribs$class, "action-button dca-palette-btn")
+  expect_identical(btn[[1]]$children[[1]]$attribs$style, "color: red;")
+  expect_identical(btn[[1]]$attribs$style, "color: red;")
+  expect_identical(btn[[2]]$stylesheet, "main.min.css")
+})

tests/testthat/test-dca_footer.R

@@ -0,0 +1,7 @@
+test_that("dcaFooter works", {
+  footer <- dcaFooter("default footer", height = "200px")
+  expect_identical(footer$attribs$class, "dca-footer-placeholder")
+  expect_identical(footer$attribs$style, "height: 200px;")
+  expect_identical(footer$children[[1]]$attribs$class, "dca-footer")
+  expect_identical(footer$children[[1]]$attribs$style, "max-height: 200px;")
+})

tests/testthat/test-dca_waiters.R

@@ -0,0 +1,58 @@
+test_that("use_dca_waiter works", {
+  deps <- use_dca_waiter()
+  expect_length(deps, 2)
+  expect_identical(deps[[2]]$stylesheet, "main.min.css")
+})
+
+test_that("waiter works", {
+  library(shiny)
+  library(shinydashboard)
+  library(dcamodules)
+
+  ui <- dashboardPage(
+    dashboardHeader(),
+    dashboardSidebar(),
+    dashboardBody(
+      use_dca_waiter(),
+      # landing
+      dca_waiter("show", is.landing = TRUE)
+    )
+  )
+
+  server <- function(input, output, session) {
+    observeEvent(input$waiter, {
+      t <- 0
+      # not certified
+      dca_waiter("update", is.landing = TRUE, is.certified = FALSE, sleep = t)
+      # not enought permission
+      dca_waiter("update", is.landing = TRUE, is.permission = FALSE, sleep = t)
+      # success login
+      dca_waiter("update", is.landing = TRUE, sleep = t)
+      # simple waiter screens
+      dca_waiter("show", sleep = t)
+      dca_waiter("update", sleep = t, is.stop = TRUE)
+      dca_waiter("hide", sleep = t)
+    })
+  }
+
+  testServer(server, {
+    # iniate all waiters in server
+    session$setInputs(waiter = 1)
+  })
+})
+
+test_that("waiter warning works", {
+  expect_warning(
+    dca_waiter("show", is.landing = TRUE, is.stop = TRUE),
+    "'is.stop' is not used when 'is.landing' is TRUE"
+  )
+})
+
+test_that("spin_logo works", {
+  svg_spinner <- spin_logo("synapse")
+  png_spinner <- spin_logo("htan")
+  expect_identical(class(svg_spinner[[1]]), "shiny.tag")
+  expect_identical(class(png_spinner[[1]]), "shiny.tag")
+  expect_identical(svg_spinner[[1]]$attribs$class, "dca-logo-spin")
+  expect_identical(png_spinner[[1]]$attribs$class, "dca-logo-spin")
+})

tests/testthat/test-mod_palette_panel.R

@@ -0,0 +1,3 @@
+test_that("multiplication works", {
+  expect_equal(2 * 2, 4)
+})

tests/testthat/test-mod_switch_button.R

@@ -0,0 +1,3 @@
+test_that("multiplication works", {
+  expect_equal(2 * 2, 4)
+})

tests/testthat/test-set_theme.R

@@ -0,0 +1,3 @@
+test_that("multiplication works", {
+  expect_equal(2 * 2, 4)
+})

tests/testthat/test-utils.R

@@ -0,0 +1,42 @@
+test_that("get_tab_names works", {
+  tab_object <- tabItems(
+    tabItem(tabName = "tab1"),
+    tabItem(tabName = "tab2"),
+    tabItem(tabName = "tab3")
+  )
+  res <- get_tab_names(tab_object)
+  expect_identical(res, c("tab1", "tab2", "tab3"))
+})
+
+test_that("var_to_server works", {
+  ui <- var_to_server("values", 1:3)
+  expect_true(grepl("dca-remove", ui$attribs$class))
+  # TODO: add test on values in server
+})
+
+test_that("insert_attribute with single tag works", {
+  tag <- insert_attribute(
+    div(),
+    id = "test-id"
+  )
+  tag2 <- insert_attribute(
+    tags$div(list(tags$i(), tags$i())),
+    id = "test-id",
+    pos = 2
+  )
+  expect_identical(tag$attribs$id, "test-id")
+  expect_identical(tag2$children[[1]][[2]]$attribs$id, "test-id")
+  expect_identical(tag2$children[[1]][[1]]$attribs$id, NULL)
+})
+
+test_that("drop_empty with drop = 'all' works", {
+  test_data <- c("real", "null", NULL, NA, "  ")
+  res_all <- drop_empty(test_data)
+  res_na <- drop_empty(test_data, drop = "na")
+  res_null <- drop_empty(test_data, drop = "null")
+  res_blank <- drop_empty(test_data, drop = "blank")
+  expect_identical(res_all, "real")
+  expect_identical(res_na, c("real", "null", "  "))
+  expect_identical(res_null, c("real", NA, "  "))
+  expect_identical(res_blank, c("real", "null", NA))
+})