R/swipeR.R

In swipeR: Carousels using the 'JavaScript' Library 'Swiper'

#' @title List of DOM elements for a carousel
#' @description Enclose a list of DOM elements in a HTML \code{div} element
#'   to be passed to the \code{\link{swipeR}} function.
#'
#' @param ... HTML elements, one for each slide
#'
#' @return A \code{shiny.tag} object.
#' @export
#' @importFrom htmltools div
swipeRwrapper <- function(...) {
  elements <- list(...)
  do.call(
    function(...) {
      div(class = "swiper-wrapper", ...)
    },
    lapply(elements, function(el) {
      div(class = "swiper-slide", el)
    })
  )
}

#' @title HTML widget displaying a carousel
#' @description Create a HTML widget displaying a carousel.
#'
#' @param wrapper HTML \code{div} element created with \code{\link{swipeRwrapper}}
#' @param width,height dimensions
#' @param navigationColor color for the navigation arrows
#' @param paginationColor color for the pagination bullets
#' @param bulletsSize size of the pagination bullets
#' @param id a HTML id for the carousel
#' @param direction direction of the slide show, \code{"horizontal"} or \code{"vertical"}
#' @param effect transition effect, can be \code{"slide"}, \code{"fade"},
#'   \code{"cube"}, \code{"coverflow"}, \code{"flip"}, or \code{"cards"}
#' @param cubeEffect list of settings for the cube when \code{effect="cube"}
#' @param initialSlide index of the first slide to be shown
#' @param keyboard named list of settings for the keyboard navigation, or just
#'   \code{TRUE} to enable the keyboard navigation with the default options,
#'   or \code{FALSE} to disable the keyboard navigation
#' @param zoom Boolean, whether to enable the zoom on slide's double tap;
#'   all zoomable slides must be wrapped in a \code{div} with
#'   \code{swiper-zoom-container} class
#' @param loop Boolean, whether to enable the continuous loop mode
#' @param rewind Boolean; if \code{TRUE}, clicking "next" navigation button
#'   when on last slide will slide back to the first slide, and clicking "prev"
#'   navigation button when on first slide will style forward to the last slide
#' @param slidesPerView number of slides per view
#' @param spaceBetween distance between slides in pixels
#' @param speed transition speed in milliseconds
#' @param scrollbar Boolean, whether to enable a scrollbar for navigation
#' @param autoplay Boolean, whether to autoplay the slide show
#' @param thumbs Boolean, whether to display thumbs of the slides
#' @param thumbsPerView number of thumbs per view
#' @param thumbsHeight height of the thumbs carousel
#' @param on named list of event listeners
#' @param elementId a HTML id for the container
#'
#' @return A \code{htmlwidget} object.
#' @export
#' @importFrom htmlwidgets createWidget
#'
#' @examples
#' library(swipeR)
#' library(htmltools)
#'
#' wrapper <- swipeRwrapper(
#'   tags$img(src = "https://swiperjs.com/demos/images/nature-1.jpg"),
#'   tags$img(src = "https://swiperjs.com/demos/images/nature-2.jpg"),
#'   tags$img(src = "https://swiperjs.com/demos/images/nature-3.jpg"),
#'   tags$img(src = "https://swiperjs.com/demos/images/nature-4.jpg"),
#'   tags$img(src = "https://swiperjs.com/demos/images/nature-5.jpg"),
#'   tags$img(src = "https://swiperjs.com/demos/images/nature-6.jpg"),
#'   tags$img(src = "https://swiperjs.com/demos/images/nature-7.jpg"),
#'   tags$img(src = "https://swiperjs.com/demos/images/nature-8.jpg")
#' )
#'
#' swipeR(
#'   wrapper, height = "400px", width = "70%", thumbs = TRUE, keyboard = TRUE,
#'   on = list(reachEnd = htmlwidgets::JS("function() {alert('the end');}"))
#' )
#'
#' # Shiny example ####
#' library(swipeR)
#' library(shiny)
#' library(ggplot2)
#'
#' wrapper <- swipeRwrapper(
#'   div(
#'     plotOutput("ggplot1", width = "500px", height = "400px"),
#'     align = "center"
#'   ),
#'   div(
#'     plotOutput("ggplot2", width = "500px", height = "400px"),
#'     align = "center"
#'   ),
#'   div(
#'     plotOutput("ggplot3", width = "500px", height = "400px"),
#'     align = "center"
#'   ),
#'   div(
#'     plotOutput("ggplot4", width = "500px", height = "400px"),
#'     align = "center"
#'   )
#' )
#'
#' ui <- fluidPage(
#'   tags$head(
#'     tags$style(HTML(
#'       ".shiny-plot-output {border: 2px solid royalblue;}"
#'     ))
#'   ),
#'   br(),
#'   fluidRow(
#'     column(
#'       12,
#'       swipeR(
#'         wrapper, height = "450px", width = "80%", effect = "cube", speed = 2000,
#'         navigationColor = "black", rewind = TRUE, id = "CAROUSEL"
#'       )
#'     ),
#'     column(
#'       12,
#'       br(), br(), br(),
#'     ),
#'     column(
#'       3, align = "center",
#'       actionButton(
#'         "btn1", "Scatter plot", class = "btn-primary",
#'         onclick = "document.getElementById('CAROUSEL').swiper.slideTo(0);"
#'       )
#'     ),
#'     column(
#'       3, align = "center",
#'       actionButton(
#'         "btn2", "Line chart", class = "btn-primary",
#'         onclick = "document.getElementById('CAROUSEL').swiper.slideTo(1);"
#'       )
#'     ),
#'     column(
#'       3, align = "center",
#'       actionButton(
#'         "btn3", "Bar chart", class = "btn-primary",
#'         onclick = "document.getElementById('CAROUSEL').swiper.slideTo(2);"
#'       )
#'     ),
#'     column(
#'       3, align = "center",
#'       actionButton(
#'         "btn4", "Boxplots", class = "btn-primary",
#'         onclick = "document.getElementById('CAROUSEL').swiper.slideTo(3);"
#'       )
#'     )
#'   )
#' )
#'
#' server <- function(input, output, session) {
#'   output[["ggplot1"]] <- renderPlot({
#'     ggplot(mtcars, aes(wt, mpg)) + geom_point() +
#'       theme(panel.border = element_rect(fill = NA, color = "firebrick"))
#'   }, width = 500, height = 400)
#'   output[["ggplot2"]] <- renderPlot({
#'     ggplot(economics, aes(date, unemploy)) + geom_line()
#'   }, width = 500, height = 400)
#'   output[["ggplot3"]] <- renderPlot({
#'     ggplot(mpg, aes(class)) + geom_bar()
#'   }, width = 500, height = 400)
#'   output[["ggplot4"]] <- renderPlot({
#'     ggplot(mpg, aes(class, hwy)) + geom_boxplot()
#'   }, width = 500, height = 400)
#' }
#'
#' if(interactive()) shinyApp(ui, server)
#'
#'
#' # other Shiny example ####
#' library(swipeR)
#' library(shiny)
#' library(shinyWidgets)
#' library(ggplot2)
#' library(ggthemes)
#'
#' wrapper <- swipeRwrapper(
#'   div(
#'     fluidRow(
#'       column(
#'         6,
#'         awesomeRadio(
#'           "theme", "Choose a theme",
#'           c(
#'             "Calc",
#'             "Clean",
#'             "Economist",
#'             "Excel",
#'             "FiveThirtyEight",
#'             "Foundation",
#'             "Google Docs",
#'             "Highcharts",
#'             "Pander",
#'             "Solarized",
#'             "Stata",
#'             "Wall Street"
#'           )
#'         )
#'       ),
#'       column(
#'         6,
#'         tags$p("The Shiny slider does not work here..."),
#'         tags$label("Base font size"),
#'         tags$input(
#'           type = "range", min = "10", max = "20", value = "12",
#'           oninput =
#'             "this.nextElementSibling.value = this.value;
#'              Shiny.setInputValue('slider', this.value);"
#'         ),
#'         tags$output("12", style = "font-weight: bold; color: blue"),
#'         br(), hr(), br(),
#'         materialSwitch("facets", "Facets?", status = "info"),
#'         conditionalPanel(
#'           condition = "input.facets",
#'           awesomeRadio(
#'             "direction", label = NULL, status = "info",
#'             choices = c("by row" = "row", "by column" = "column"),
#'           )
#'         ),
#'         br(), hr(), br(),
#'         actionButton(
#'           "btn", "Add slide", class = "btn-primary btn-block",
#'           onclick = "document.getElementById('SWIPER').swiper.appendSlide(
#'             '<div class=\"swiper-slide rlogo\"></div>');
#'             Shiny.setInputValue('newslide', true, {priority: 'event'});"
#'         )
#'       )
#'     ),
#'     style = "margin-left: 10%; margin-right: 10%; font-size: 2rem;"
#'   ),
#'   div(
#'     plotOutput("ggplot", width = "85%", height = "400px"),
#'     align = "center"
#'   )
#' )
#'
#' ui <- fluidPage(
#'   tags$head(
#'     tags$style(HTML(
#'       ".shiny-plot-output {
#'           border: 2px solid royalblue;
#'       }
#'       .shiny-text-output {
#'           font-size: 30px;
#'           font-style: italic;
#'       }
#'       .recalculating {
#'          display: none; /* otherwise there's a flash */
#'       }
#'       .rlogo {
#'          width: 100%;
#'          height: 100%;
#'          background-image: url(https://www.r-project.org/logo/Rlogo.png);
#'          background-repeat: no-repeat;
#'          background-size: contain;
#'          background-position: center;
#'       }"
#'     ))
#'   ),
#'   br(), br(), br(),
#'   fluidRow(
#'     column(
#'       12,
#'       swipeR(
#'         wrapper, id = "SWIPER", effect = "flip", rewind = TRUE,
#'         height = "450px", width = "90%",
#'         navigationColor = "black", paginationColor = "black",
#'         on = list(
#'           afterInit = htmlwidgets::JS(
#'             "function(swiper) {
#'                setTimeout(function(){ Shiny.setInputValue('index', 1); }, 0);
#'             }"
#'           ),
#'           slideChange = htmlwidgets::JS(
#'             "function(swiper) {
#'                Shiny.setInputValue('index', swiper.activeIndex + 1);
#'             }"
#'           )
#'         )
#'       )
#'     ),
#'     column(
#'       12,
#'       textOutput("slideIndex")
#'     )
#'   )
#' )
#'
#' server <- function(input, output, session) {
#'
#'   ggtheme <- reactive({
#'     size <- input[["slider"]]
#'     size <- if(is.null(size)) 12 else as.integer(size)
#'     switch(
#'       input[["theme"]],
#'       "Calc"            = theme_calc(base_size = size),
#'       "Clean"           = theme_clean(base_size = size),
#'       "Economist"       = theme_economist(base_size = size),
#'       "Excel"           = theme_excel_new(base_size = size),
#'       "FiveThirtyEight" = theme_fivethirtyeight(base_size = size),
#'       "Foundation"      = theme_foundation(base_size = size),
#'       "Google Docs"     = theme_gdocs(base_size = size),
#'       "Highcharts"      = theme_hc(base_size = size),
#'       "Pander"          = theme_pander(base_size = size),
#'       "Solarized"       = theme_solarized(base_size = size),
#'       "Stata"           = theme_stata(base_size = size),
#'       "Wall Street"     = theme_wsj(base_size = size)
#'     )
#'   })
#'
#'   output[["ggplot"]] <- renderPlot({
#'     gg <- ggplot(iris, aes(x = Sepal.Length, y = Petal.Length, color = Species)) +
#'       geom_point(size = 6) + ggtheme()
#'     if(input[["facets"]]) {
#'       if(input[["direction"]] == "row") {
#'         gg <- gg + facet_grid(rows = vars(Species))
#'       } else {
#'         gg <- gg + facet_grid(cols = vars(Species))
#'       }
#'     }
#'     gg
#'   })
#'
#'   nSlides <- reactiveVal(2)
#'   observeEvent(input[["newslide"]], {
#'     nSlides(nSlides() + 1)
#'   })
#'
#'   output[["slideIndex"]] <- renderText({
#'     paste0(input[["index"]], "/", nSlides())
#'   })
#'
#' }
#'
#' if(interactive()) shinyApp(ui, server)
swipeR <- function(
    wrapper, width = "100%", height = "100%",
    navigationColor = "white", paginationColor = "white", bulletsSize = "8px",
    id = NULL, direction = "horizontal", effect = "slide",
    cubeEffect = list(shadow = TRUE, slidesShadow = TRUE, shadowOffset = 20,
                      shadowScale = 0.94),
    initialSlide = 1,
    keyboard = list(enabled = FALSE, onlyInViewport = TRUE, pageUpDown = TRUE),
    zoom = FALSE, loop = FALSE, rewind = FALSE,
    slidesPerView = 1, spaceBetween = 30, speed = 300,
    scrollbar = FALSE, autoplay = FALSE,
    thumbs = FALSE, thumbsPerView = 2, thumbsHeight = "60px",
    on = NULL,
    elementId = NULL
) {
  tags <- swiperDiv(
    wrapper, id, width, height, scrollbar,
    navigationColor, paginationColor, bulletsSize
  )
  if(isTRUE(keyboard)) {
    keyboard <- list(enabled = TRUE, onlyInViewport = TRUE, pageUpDown = TRUE)
  } else if(isFALSE(keyboard)) {
    keyboard <- list(enabled = FALSE, onlyInViewport = TRUE, pageUpDown = TRUE)
  }
  x <- list(
    "html"                = tags[["html"]],
    "thumbs"              = if(thumbs) thumbsDiv(wrapper, width, thumbsHeight),
    "thumbsPerView"       = thumbsPerView,
    "direction"           = match.arg(direction, c("horizontal", "vertical")),
    "effect"              =
      match.arg(
        effect,
        c("slide", "fade", "cube", "coverflow", "flip", "cards")
      ),
    "cubeEffect"          = cubeEffect,
    "initialSlide"        = initialSlide - 1,
    "keyboard"            = keyboard,
    "zoom"                = zoom,
    "loop"                = loop,
    "rewind"              = rewind && !loop,
    "slidesPerView"       = slidesPerView,
    "spaceBetween"        = spaceBetween,
    "speed"               = speed,
    "scrollbar"           = scrollbar,
    "autoplay"            = autoplay,
    "on"                  = on
  )

  createWidget(
    name = "swipeR",
    x,
    width = "100%",
    height = height,
    package = "swipeR",
    elementId = elementId,
    dependencies = tags[["dependencies"]]
  )
}

#' @title Shiny bindings for swipeR carousels
#' @description Output and render functions for using swipeR within Shiny
#'   applications.
#'
#' @param outputId output variable to read from
#' @param width,height must be a valid CSS unit (like \code{"100\%"},
#'   \code{"400px"}, \code{"auto"}) or a number, which will be coerced to a
#'   string and have \code{"px"} appended
#' @param expr an expression that generates a \code{\link{swipeR}} carousel
#' @param env the environment in which to evaluate \code{expr}
#' @param quoted Boolean, whether \code{expr} is a quoted expression
#'   (with \code{quote()}); this is useful if you want to save an expression
#'   in a variable
#'
#' @name swipeR-shiny
#'
#' @return \code{swipeROutput} returns an output element that can be included
#'   in a Shiny UI, and \code{renderSwipeR} returns a \code{shiny.render.function}
#'   object that can be assigned to an output slot in a Shiny server.
#'
#' @export
#' @importFrom htmlwidgets shinyWidgetOutput
swipeROutput <- function(outputId, width = "100%", height = "400px") {
  shinyWidgetOutput(outputId, "swipeR", width, height, package = "swipeR")
}

#' @rdname swipeR-shiny
#' @export
#' @importFrom htmlwidgets shinyRenderWidget
renderSwipeR <- function(expr, env = parent.frame(), quoted = FALSE) {
  if(!quoted) {
    expr <- substitute(expr)
  } # force quoted
  shinyRenderWidget(expr, swipeROutput, env, quoted = TRUE)
}