inst/examples/shinyWidgets/server.R

In shinyWidgets: Custom Inputs Widgets for Shiny

#  ------------------------------------------------------------------------
#
# Title : shinyWidgets Gallery - server
#    By : Victor
#  Date : 2020-12-01
#
#  ------------------------------------------------------------------------



function(input, output, session) {

  # cleanup app
  session$onSessionEnded(function() {
    suppressWarnings(
      rm(.shinyWidgetGalleryFuns, .shinyWidgetGalleryId, ID, envir = globalenv())
    )
    shiny::stopApp()
  })

  # highlight code dropdowns & sweetalert
  .shinyWidgetGalleryFuns$highlightCode(session, "code_dropdownButton")

  .shinyWidgetGalleryFuns$highlightCode(session, "code_dropdown")

  .shinyWidgetGalleryFuns$highlightCode(session, "codeSA")

  # navigation ----

  observeEvent(input$toSwictchInput, {
    updateTabItems(session = session, inputId = "tabs", selected = "tabswitchInput")
  })

  observeEvent(input$toAwesome1, {
    updateTabItems(session = session, inputId = "tabs", selected = "tabAwesome")
  })
  observeEvent(input$toAwesome2, {
    updateTabItems(session = session, inputId = "tabs", selected = "tabAwesome")
  })
  observeEvent(input$toAwesome3, {
    updateTabItems(session = session, inputId = "tabs", selected = "tabAwesome")
  })

  observeEvent(input$tocheckButtons, {
    updateTabItems(session = session, inputId = "tabs", selected = "tabcheckButtons")
  })

  observeEvent(input$toMaterialSwitch, {
    updateTabItems(session = session, inputId = "tabs", selected = "tabMaterialSwitch")
  })

  observeEvent(input$toSelectPicker, {
    updateTabItems(session = session, inputId = "tabs", selected = "tabPickerInput")
  })



  # input values ----
  lapply(
    X = seq_len(.shinyWidgetGalleryId),
    FUN = function(i) {
      ii <- paste0("Id", sprintf("%03d", i))
      .shinyWidgetGalleryFuns$highlightCode(session, paste0("code", ii))
      output[[paste0("res", ii)]] <- renderPrint({
        input[[ii]]
      })
    }
  )


  # Update switchInput
  output$resswitchUp <- renderPrint({
    input$switchUp
  })
  observeEvent(input$on, {
    updateSwitchInput(session = session, inputId = "switchUp", value = TRUE)
  })
  observeEvent(input$off, {
    updateSwitchInput(session = session, inputId = "switchUp", value = FALSE)
  })


  # Update awesomeRadios
  output$resupAwesomeRadio <- renderPrint({
    input$upAwesomeRadio
  })
  observeEvent(input$upAwesomeRadioA, {
    updateAwesomeRadio(session = session, inputId = "upAwesomeRadio", selected = "A")
  })
  observeEvent(input$upAwesomeRadioB, {
    updateAwesomeRadio(session = session, inputId = "upAwesomeRadio", selected = "B")
  })
  observeEvent(input$upAwesomeRadioC, {
    updateAwesomeRadio(session = session, inputId = "upAwesomeRadio", selected = "C")
  })

  # Update awesomeRadios
  output$resupAwesomeCheckbox <- renderPrint({
    input$upAwesomeCheckbox
  })
  observeEvent(input$upAwesomeCheckbox1, {
    updateAwesomeCheckboxGroup(session = session, inputId = "upAwesomeCheckbox", choices = c("a", "b", "c"), inline = TRUE, status = "success")
  })
  observeEvent(input$upAwesomeCheckbox2, {
    updateAwesomeCheckboxGroup(session = session, inputId = "upAwesomeCheckbox", choices = c("A", "B", "C"), inline = TRUE, status = "warning")
  })


  # update checkboxGroupButtons ----
  output$resupcheckboxGroupButtons <- renderPrint({
    input$upcheckboxGroupButtons
  })
  observeEvent(input$upCheckBtnA, {
    updateCheckboxGroupButtons(session = session, inputId = "upcheckboxGroupButtons", selected = "A")
  })
  observeEvent(input$upCheckBtnB, {
    updateCheckboxGroupButtons(session = session, inputId = "upcheckboxGroupButtons", selected = "B")
  })
  observeEvent(input$upCheckBtnC, {
    updateCheckboxGroupButtons(session = session, inputId = "upcheckboxGroupButtons", selected = "C")
  })
  observeEvent(input$upCheckBtnD, {
    updateCheckboxGroupButtons(session = session, inputId = "upcheckboxGroupButtons", selected = "D")
  })


  # Update radioGroupButtons ----
  output$resupradioGroupButtons <- renderPrint({
    input$upradioGroupButtons
  })
  observeEvent(input$upRadioBtnA, {
    updateRadioGroupButtons(session = session, inputId = "upradioGroupButtons", selected = "A")
  })
  observeEvent(input$upRadioBtnB, {
    updateRadioGroupButtons(session = session, inputId = "upradioGroupButtons", selected = "B")
  })
  observeEvent(input$upRadioBtnC, {
    updateRadioGroupButtons(session = session, inputId = "upradioGroupButtons", selected = "C")
  })
  observeEvent(input$upRadioBtnD, {
    updateRadioGroupButtons(session = session, inputId = "upradioGroupButtons", selected = "D")
  })





  # Update materialSwitch ----
  output$resupMaterial <- renderPrint({
    input$upMaterial
  })
  observeEvent(input$upMaterialY, {
    updateMaterialSwitch(session = session, inputId = "upMaterial", value = TRUE)
  })
  observeEvent(input$upMaterialN, {
    updateMaterialSwitch(session = session, inputId = "upMaterial", value = FALSE)
  })






  # Update PickerInput ----
  output$resuppickerIcons <- renderPrint({
    input$uppickerIcons
  })
  observeEvent(input$uppickerIconsRadio, {
    if (input$uppickerIconsRadio == "Glyphicon") {
      updatePickerInput(
        session = session, inputId = "uppickerIcons", selected = input$uppickerIcons,
        choices = c("glyphicon-arrow-right / fa-arrow-right", "glyphicon-cog / fa-cog", "glyphicon-play / fa-play",
                    "glyphicon-ok-sign / fa-check", "glyphicon-euro / fa-eur", "glyphicon-music / fa-music"),
        choicesOpt = list(
          icon = c("glyphicon glyphicon-arrow-right", "glyphicon glyphicon-cog", "glyphicon glyphicon-play",
                   "glyphicon glyphicon-ok-sign", "glyphicon glyphicon-euro", "glyphicon glyphicon-music")
        )
      )
    } else {
      updatePickerInput(
        session = session, inputId = "uppickerIcons", selected = input$uppickerIcons,
        choices = c("glyphicon-arrow-right / fa-arrow-right", "glyphicon-cog / fa-gear", "glyphicon-play / fa-play",
                    "glyphicon-ok-sign / fa-check", "glyphicon-euro / fa-eur", "glyphicon-music / fa-music"),
        choicesOpt = list(
          icon = c("fa fa-arrow-right", "fa fa-gear", "fa fa-play",
                   "fa fa-check", "fa fa-eur", "fa fa-music")
        )
      )
    }
  })



  # Update sliderText ----

  output$resselectedSliderText <- renderPrint({
    input$selectedSliderText
  })
  observeEvent(input$upSelectedSliderText, {
    updateSliderTextInput(
      session = session,
      inputId = "selectedSliderText",
      selected = input$upSelectedSliderText
    )
  }, ignoreInit = TRUE)

  output$reschoicesSliderText <- renderPrint({
    input$choicesSliderText
  })
  observeEvent(input$upChoicesSliderText, {
    choices <- switch(
      input$upChoicesSliderText,
      "Abbreviations" = month.abb,
      "Full names" = month.name
    )
    updateSliderTextInput(
      session = session,
      inputId = "choicesSliderText",
      choices = choices
    )
  }, ignoreInit = TRUE)




  # dropdown : iris clustering example ----
  selectedData <- reactive({
    iris[, c(input$xcol, input$ycol)]
  })

  clusters <- reactive({
    kmeans(selectedData(), input$clusters)
  })

  output$plot1 <- renderPlot({
    palette(c("#E41A1C", "#377EB8", "#4DAF4A", "#984EA3",
              "#FF7F00", "#FFFF33", "#A65628", "#F781BF", "#999999"))

    par(mar = c(5.1, 4.1, 0, 1))
    plot(selectedData(),
         col = clusters()$cluster,
         pch = 20, cex = 3)
    points(clusters()$centers, pch = 4, cex = 4, lwd = 4)
  })


  # dropdown 2 : iris clustering example ----
  selectedData2 <- reactive({
    iris[, c(input$xcol2, input$ycol2)]
  })

  clusters2 <- reactive({
    kmeans(selectedData2(), input$clusters2)
  })

  output$plot2 <- renderPlot({
    palette(c("#E41A1C", "#377EB8", "#4DAF4A", "#984EA3",
              "#FF7F00", "#FFFF33", "#A65628", "#F781BF", "#999999"))

    par(mar = c(5.1, 4.1, 0, 1))
    plot(selectedData2(),
         col = clusters2()$cluster,
         pch = 20, cex = 3)
    points(clusters2()$centers, pch = 4, cex = 4, lwd = 4)
  })



  # sweetalert ----
  observeEvent(input$success, {
    sendSweetAlert(
      session = session, title = "Success !!", text = "All in order", type = "success"
    )
  })

  observeEvent(input$error, {
    sendSweetAlert(
      session = session, title = "Error...", text = "Oups !", type = "error"
    )
  })

  observeEvent(input$info, {
    sendSweetAlert(
      session = session, title = "Information", text = "Something helpful", type = "info"
    )
  })

  # observeEvent(input$tags, {
  #   sendSweetAlert(
  #     session = session, title = "HTLM tags",
  #     text = "normal <b>bold</b> <span style='color: steelblue;'>color</span> <h1>h1</h1>", html = TRUE, type = NULL
  #   )
  # })

  observeEvent(input$warning, {
    sendSweetAlert(
      session = session, title = "Warning !!!",
      text = NULL, type = "warning"
    )
  })


  observeEvent(input$launch_confirmation, {
    confirmSweetAlert(
      session = session, inputId = "myconfirmation", type = "warning",
      title = "Want to confirm ?", danger_mode = TRUE
    )
  })
  output$res_confirmation <- renderPrint(input$myconfirmation)

  # Progress Bars ----

  lapply(
    X = paste0("pb", 1:10),
    FUN = function(i) {
      .shinyWidgetGalleryFuns$highlightCode(session, paste0("code", i))
    }
  )

  observeEvent(input$uppb1, {
    updateProgressBar(session = session, id = "pb1", value = input$uppb1)
  })

  observeEvent(input$uppb2, {
    updateProgressBar(session = session, id = "pb2", value = input$uppb2)
  })

  observeEvent(input$uppb3, {
    updateProgressBar(session = session, id = "pb3", value = input$uppb3)
  })

  observeEvent(input$uppb4, {
    updateProgressBar(session = session, id = "pb4", value = input$uppb4)
  })

  observeEvent(input$uppb5, {
    updateProgressBar(session = session, id = "pb5", value = input$uppb5, total = 5000)
  })

  observeEvent(input$uppb6, {
    updateProgressBar(session = session, id = "pb6", value = input$uppb6)
  })

  observeEvent(input$uppb7, {
    if (input$uppb7 < 33) {
      status <- "danger"
    } else if (input$uppb7 >= 33 & input$uppb7 < 67) {
      status <- "warning"
    } else {
      status <- "success"
    }
    updateProgressBar(session = session, id = "pb7", value = input$uppb7, status = status)
  })

  observeEvent(input$uppb8, {
    updateProgressBar(session = session, id = "pb8", value = input$uppb8, total = 5000)
  })

  observeEvent(input$uppb9, {
    updateProgressBar(session = session, id = "pb9", value = 1000, total = input$uppb9)
  })


}