add `actionButton()` to pop up

[fmmattioni]

Hi! Really cool package!

Is it possible to somehow add an actionButton() to the pop up?

[pvictor]

Hello,

Yes you can HTML tags in the popup. The only tricky thing if you put multiple buttons is how to retrieve input values server-side, so i'll use Shiny.setInputValue to have one input for all buttons instead of as many inputs as buttons.

Here's an example:

library(tuicalendr)
library(htmltools)
library(shiny)

# Calendar properties ----
calendarProps <- data.frame(
  id = c("1", "2", "3"), 
  name = c("TODO", "Meetings", "Tasks"),
  color = c("#FFF", "#FFF", "#000"), 
  bgColor = c("#E41A1C", "#377EB8", "#4DAF4A"),
  borderColor = c("#a90000", "#005288", "#0a7f1c")
)

# Schedules data ---
n <- 20
date_start <- sample(
  seq(from = as.POSIXct(Sys.Date()-14), by = "1 hour", length.out = 24*7*4),
  n, TRUE
)
date_end <- date_start + sample(1:25, n, TRUE) * 3600
schedules <- data.frame(
  id = 1:n, 
  calendarId = as.character(sample(1:3, n, TRUE)),
  title = LETTERS[1:n],
  start = format(date_start, format = "%Y-%m-%dT%H:%00:%00"),
  end = format(date_end, format = "%Y-%m-%dT%H:%00:%00"),
  category = sample(c("allday", "time", "task"), n, TRUE),
  stringsAsFactors = FALSE
)

# HTML popup content
make_body <- function(title, id) {
  doRenderTags(tags$div(
    tags$h3("Title for", title),
    tags$p(
      "Yan can write", tags$em("custom"), tags$b("HTML"),
      "in a popup !"
    ),
    tags$p(
      style = "color: firebrick;",
      "For example write in red !"
    ),
    tags$ul(
      tags$li("Or make a bullet list!"),
      tags$li("With another item"),
      tags$li("And one more")
    ),
    actionButton(
      inputId = paste0("btn_input_", id), 
      label = paste("Label", id), 
      width = "100%",
      onclick = sprintf("Shiny.setInputValue('click_button', %s);", id)
    )
  ))
}
schedules$body <- unlist(mapply(FUN = make_body, title = schedules$title, id = schedules$id))

# App ----
ui <- fluidPage(
  fluidRow(
    column(
      width = 9,
      calendarOutput(outputId = "cal")
    ),
    column(
      width = 3,
      tags$b("Click:"),
      verbatimTextOutput("click")
    )
  )
)

server <- function(input, output, session) {
  output$cal <- renderCalendar({
    calendar(defaultView = "month", taskView = TRUE, scheduleView = c("time", "allday")) %>% 
      set_calendars_props_df(df = calendarProps) %>% 
      add_schedule_df(df = schedules)
  })
  output$click <- renderPrint({
    input$click_button
  })
}

shinyApp(ui, server)

Victor

[fmmattioni]

Hey, @pvictor,

This is truly incredible! Thanks a lot for the tips!!!

[fmmattioni]

By the way, is there a specific JS command I could use to close the pop up once the button is clicked too?

[pvictor]

Not sure how to do that... Otherwise there's the solution to use a custom popup : https://github.com/dreamRs/tuicalendr/blob/master/inst/calendar-examples/custom-popover.R