Add switch button (#4)

* add module - tab switch button

* fix tab switch bug

* update pr ci to monitor changes on .R files

* update pr-ci

* update pr-ci

* change commit message

* add echo msg if no changes to commit

* Github Actions: style

* add styler cache

Co-authored-by: rrchai <[email protected]>

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

@@ -1,10 +1,11 @@
 # Workflow derived from https://github.com/r-lib/actions/tree/master/examples
 # Need help debugging build failures? Start at https://github.com/r-lib/actions#where-to-find-help
 on:
-  issue_comment:
-    types: [created]
+  pull_request:
+    branches: main
+    paths: '**/*.R'
 
-name: Commands
+name: PR-CI
 
 jobs:
   # document:
@@ -43,9 +44,8 @@ jobs:
       #     repo-token: ${{ secrets.GITHUB_TOKEN }}
 
   style:
-    if: ${{ github.event.issue.pull_request && (github.event.comment.author_association == 'MEMBER' || github.event.comment.author_association == 'OWNER') && startsWith(github.event.comment.body, '/style') }}
-    name: style
-    runs-on: ubuntu-latest
+    name: styler
+    runs-on: macOS-latest
     env:
       GITHUB_PAT: ${{ secrets.GITHUB_TOKEN }}
     steps:
@@ -60,6 +60,23 @@ jobs:
       - name: Install dependencies
         run: Rscript -e 'install.packages("styler")'
 
+      - name: save R.cache location
+        id: save-r-cache-location
+        run: |
+          cat("##[set-output name=r-cache-location;]", R.cache::getCacheRootPath(), "\n", sep = "")
+        shell: Rscript {0}
+
+      - name: R.cache cache
+        uses: actions/cache@v2
+        env:
+          cache-name: r-cache
+        with:
+          path: ${{ r-cache-location }}
+          key: ${{ runner.os }}-${{ env.cache-name }}-${{ github.sha }}
+          restore-keys: |
+            ${{ runner.os }}-${{ env.cache-name }}-
+            ${{ runner.os }}-
+
       - name: Style
         run: Rscript -e 'styler::style_pkg()'
 
@@ -68,7 +85,7 @@ jobs:
           git config --local user.name "$GITHUB_ACTOR"
           git config --local user.email "[email protected]"
           git add \*.R
-          git commit -m 'Style'
+          git commit -m 'Github Actions: style' || echo "No changes to commit"
 
       - uses: r-lib/actions/pr-push@v1
         with:

NAMESPACE

@@ -4,6 +4,7 @@ export(arrowButton)
 export(dcaFooter)
 export(dcaWaiter)
 export(dropEmptys)
+export(getTabNames)
 export(mediaButton)
 export(paletteButton)
 export(palettePanel)
@@ -12,7 +13,11 @@ export(set_theme)
 export(shinyButton)
 export(showcase)
 export(spin_logo)
+export(tabSwitch)
+export(tabSwitchUI)
 export(tagInsertAttribute)
 export(update_css)
 export(use_dcaWaiter)
+export(var2server)
 import(shiny)
+importFrom(magrittr,"%>%")

R/dca_buttons.R

@@ -50,7 +50,7 @@ arrowButton <- function(id, direction = "left", ...) {
     class = sprintf("btn btn-default action-button dca-%s-btn", direction),
     `data-val` = value,
     list(
-      ifelse(direction == "left", icon_left, icon_right)
+      if (direction == "left") icon_left else icon_right
     ),
     ...
   )
@@ -100,4 +100,4 @@ paletteButton <- function(id, color, ...) {
     ...
   )
   add_deps(btn)
-}
+}

R/dca_footer.R

@@ -10,7 +10,7 @@
 dcaFooter <- function(message, media = NULL, height = "100px", ...) {
   tags$div(
     class = "dca-footer-placeholder",
-    style = sprintf("max-height: %s;", height),
+    style = sprintf("height: %s;", height),
     tags$footer(
       class = "dca-footer",
       style = sprintf("max-height: %s;", height),

R/mod_switch_button.R

@@ -0,0 +1,92 @@
+#' Create switch button
+#'
+#' @param id The input variable to read value from
+#' @param .tab The \code{tabItem} object
+#'
+#' @importFrom magrittr %>%
+#' @export
+tabSwitchUI <- function(.tab, id = NULL) {
+  if (is.null(id)) id <- "dca-tab-switch"
+  ns <- NS(id)
+
+  n_tabs <- length(.tab$children)
+
+  tab_names <- getTabNames(.tab)
+  var1 <- var2server(ns("tab-names"), tab_names)
+
+  switch_btn_ids <- c(NS("prev", n_tabs))
+
+  .tab$children[[n_tabs]] <- .tab$children[[n_tabs]] %>%
+    tagAppendChild(
+      fluidRow(
+        lapply(1:3, function(i) br()),
+        column(1, offset = 1, arrowButton(ns(NS("prev", n_tabs)), "left")),
+        lapply(1:3, function(i) br())
+      )
+    )
+
+  if (n_tabs > 1) {
+    .tab$children[[1]] <- .tab$children[[1]] %>%
+      tagAppendChild(
+        fluidRow(
+          lapply(1:3, function(i) br()),
+          column(1, offset = 10, arrowButton(ns(NS("next", 1)), "right")),
+          lapply(1:3, function(i) br())
+        )
+      )
+    switch_btn_ids <- c(switch_btn_ids, NS("next", 1))
+  }
+
+  if (n_tabs > 2) {
+    lapply(2:(n_tabs - 1), function(i) {
+      .tab$children[[i]] <<- .tab$children[[i]] %>%
+        tagAppendChild(
+          fluidRow(
+            lapply(1:3, function(i) br()),
+            column(1, offset = 1, arrowButton(ns(NS("prev", i)), "left")),
+            column(1, offset = 8, arrowButton(ns(NS("next", i)), "right")),
+            lapply(1:3, function(i) br()),
+          )
+        )
+      switch_btn_ids <<- c(switch_btn_ids, c(NS("prev", i), NS("next", i)))
+    })
+  }
+
+  var2 <- var2server(ns("switch-ids"), switch_btn_ids)
+
+  return(tagList(.tab, var1, var2))
+}
+
+#' Tab switch button server
+#'
+#' @param id The input id to read value from
+#' @param tab.id The id of \code{tabItem} object
+#' @param parent.session The session from parent scope
+#' @param parent.input The input from parent scope
+#' @param parent.output The output from parent scope
+#'
+#' @export
+#'
+tabSwitch <- function(id, tab.id, parent.session, parent.input, parent.output) {
+  moduleServer(
+    id,
+    function(input, output, session) {
+      lapply(isolate(input[["switch-ids"]]), function(name) {
+        observeEvent(input[[name]],
+          {
+            tab_names <- input[["tab-names"]]
+            curr_inx <- which(tab_names == parent.input[[tab.id]])
+            # switch to next/previous tab based on which btn is clicked
+            i <- ifelse(grepl("prev-[1-9+]", name), -1, 1)
+            shinydashboard::updateTabItems(parent.session,
+              tab.id,
+              selected = tab_names[curr_inx + i]
+            )
+          },
+          ignoreNULL = TRUE,
+          ignoreInit = FALSE
+        )
+      })
+    }
+  )
+}

R/utils.R

@@ -1,3 +1,37 @@
+#' Extract tab names
+#'
+#' @param .tab The \code{tabItem} object
+#'
+#' @export
+getTabNames <- function(.tab) {
+  sapply(.tab$children, function(tab) {
+    id <- htmltools::as.tags(tab)$attribs$id
+    gsub("shiny-tab-", "", id)
+  })
+}
+
+
+#' var2server
+#'
+#' @description Use this trick to send variables from ui to server in module
+#' @param id The input variable to read value from
+#' @param values The values need to be sent
+#'
+#' @export
+#'
+var2server <- function(id, values) {
+  out <- selectInput(id,
+    "",
+    choices = values,
+    selected = values,
+    multiple = TRUE
+  )
+  out$attribs$class <- paste0(out$attribs$class, " dca-remove")
+
+  return(out)
+}
+
+
 #' tagInsertAttribute
 #'
 #' @param .tag The tag object

inst/examples/app.R

@@ -1,7 +1,7 @@
 library(shiny)
 library(shinydashboard)
 library(dcamodules)
-library(dplyr)
+library(magrittr)
 
 ### general
 themes <- c("default", "sage")
@@ -147,7 +147,7 @@ ui <- dashboardPage(
           actionButton("demo-act-btn6", "Danger", class = "btn-danger")
         )
       )
-    ),
+    ) %>% tabSwitchUI("switch_btn"),
     dcaFooter(
       HTML(paste0(
         "Copy right @2022. Powered by ",
@@ -170,6 +170,8 @@ server <- function(input, output, session) {
     })
   })
 
+  tabSwitch("switch_btn", "tabs", session, input, output)
+
   lapply(c("loading", "no_cert", "no_perm", "success"), function(i) {
     observeEvent(input[[paste0("btn_waiter_", i)]], {
       dcaWaiter("hide", sleep = 0)