Answers ( 2 )

  1. 2017-01-09 17:01

    Check out this gist: https://gist.github.com/haozhu233/dbf4cc45b5cc0e8a8397efac21e70d87

    I'm using ggplot here but you can try to do it with a htmlwidget, like d3heatmap, so the color change can happen at the front end.

    library(shiny)
    library(ggplot2)
    library(dplyr)
    
    server <- function(input, output, session){
      weekdays <- c("Sunday", "Monday", "Tuesday", "Wednesday", 
                    "Thursday", "Friday", "Saturday")
    
      rv <- reactiveValues(
        dt = data.frame(
          days = factor(unlist(lapply(weekdays, rep, 24)), rev(weekdays)),
          hours = 0:23,
          status = 0
        ) 
      )
    
      output$plot <- renderPlot({
        rv$dt %>%
          mutate(status = factor(status, 0:1, c("Blocked", "Allowed"))) %>%
        ggplot(aes(hours, days, fill = status)) + 
          geom_tile(color = "white") + 
          scale_x_continuous(expand = c(0, 0), 
                             breaks = seq(-0.5, 22.5, 1), 
                             label = 0:23) + 
          scale_y_discrete(expand = c(0, 0)) +
          theme(axis.ticks.y = element_blank())
      })
    
      observeEvent(input$plot_click, {
        plot_click_x <- round(input$plot_click$x)
        plot_click_y <- factor(round(input$plot_click$y), 1:7, rev(weekdays))
        rv$dt$status[rv$dt$days == plot_click_y & rv$dt$hours == plot_click_x] <- 
          1 - rv$dt$status[rv$dt$days == plot_click_y & rv$dt$hours == plot_click_x]
      })
    }
    
    ui <- fluidPage(
      plotOutput("plot", click = "plot_click")
    )
    
    shinyApp(ui, server)
    
  2. 2017-01-10 01:01

    As mentioned in the comments, here's a solution with DT:

    library(shiny)
    library(dplyr)
    library(DT)
    
    toggleTable <- matrix(" ", nrow = 7, ncol = 24, 
                          dimnames = list(
                            c("Sunday", "Monday", "Tuesday", "Wednesday", "Thursday", "Friday", "Saturday"), 
                            seq.int(1, 24, 1)))
    
    server <- function(input, output, session){
    
      output$userChoiceTbl <- DT::renderDataTable({
    
        datatable(toggleTable,
                  options = list(dom = 't',
                                 ordering = F),
                  selection = list(target = 'cell'),
                  class = 'cell-border compact') %>%
          formatStyle(1:24, cursor = 'pointer')
    
      })
    
      output$selectedInfo <- renderPrint({
        input$userChoiceTbl_cells_selected
      })
    }
    
    ui <- fluidPage(
      DT::dataTableOutput("userChoiceTbl", width = "50%"),
      tags$b("Cells Selected:"),
      verbatimTextOutput("selectedInfo")
    )
    
    shinyApp(ui = ui, server = server)
    

    enter image description here

◀ Go back