Adding custom fields to add_schedule_df and edit

[pythiantech]

I am creating a calendar in a Shiny application which generates entries based on timelines of certain milestone events. These are in a dataframe and I am able to display details in the body column. However, is there some way of editing the event which includes the columns that are custom defined. For example, I want the user to change the status of the activity by marking it as "Completed", "In Progress" or "Closed". Is there some way of adding additional fields to the popup which comes up while editing a schedule?

[pythiantech]

I noticed here that there is a property called raw which allows user data. However if I add this in my schedule, it doesn't show in the popup. The way I am adding it is raw = list(myCustomValue = 'Value'). Am I missing something?

calendar(readOnly = FALSE, useCreationPopup = TRUE) %>% 
  add_schedule(
    title = 'Test',
    body = 'This is the body',
    start = sprintf("%s 08:00:00", Sys.Date() - 1),
    end = sprintf("%s 12:30:00", Sys.Date() - 1),
    raw = list(myCustomValue = 'Value')
  )

[pvictor]

Hello,

Sorry for late answer. raw is only used to store data, it won't affect schedule display. Unfortunately the edit template can't be modified. I see 2 workaround to do something like you want:

• Use calendar props (if you're not already using it):

library(shiny)
library(tuicalendr)

ui <- fluidPage(
  tags$h2("Create, edit and remove schedule interactively"),
  
  tags$p("Click on the calendar to create a new schedule, then you will be able to edit or delete it."),
  
  fluidRow(
    column(
      width = 9,
      calendarOutput("my_calendar")
    ),
    column(
      width = 3,
      uiOutput("schedule_add"),
      uiOutput("schedule_update"),
      uiOutput("schedule_delete")
    )
  )
)

server <- function(input, output) {
  
  # Create calendar
  
  output$my_calendar <- renderCalendar({
    cal <- calendar(
      defaultDate = Sys.Date(),
      useNav = TRUE,
      readOnly = FALSE,
      useCreationPopup = TRUE
    ) %>%
      set_month_options(narrowWeekend = TRUE) %>%
      set_calendars_props(id = "completed", name = "Completed", color = "#FFF", bgColor = "#E41A1C") %>% 
      set_calendars_props(id = "progress", name = "In progress", color = "#FFF", bgColor = "#377EB8") %>% 
      set_calendars_props(id = "closed", name = "Closed", color = "#FFF", bgColor = "#4DAF4A") %>% 
      add_schedule(
        id = "test",
        calendarId = "progress",
        title = "Schedule in progress",
        body = "Body content",
        start = paste(Sys.Date(), "08:00:00"),
        end = paste(Sys.Date(), "12:30:00"),
        category = "time"
      )
  })
  
  
  # Interactive counter to give ID to schedules created/edited/deleted
  schedule_count <- reactiveVal(0)
  
  
  
  # Display changes
  
  output$schedule_add <- renderUI({
    if (!is.null(input$my_calendar_add)) {
      new <- input$my_calendar_add
      tags$div(
        "Schedule",
        tags$b(paste0("schedule_", schedule_count())),
        "have been added with:",
        tags$ul(
          lapply(
            seq_along(new),
            function(i) {
              tags$li(
                tags$b(names(new)[i], ":"),
                new[[i]]
              )
            }
          )
        )
      )
    }
  })
  
  output$schedule_update <- renderUI({
    if (!is.null(input$my_calendar_update)) {
      changes <- input$my_calendar_update$changes
      tags$div(
        "Schedule",
        tags$b(input$my_calendar_update$schedule$id),
        "have been updated with:",
        tags$ul(
          lapply(
            seq_along(changes),
            function(i) {
              tags$li(
                tags$b(names(changes)[i], ":"),
                changes[[i]]
              )
            }
          )
        )
      )
    }
  })
  
  output$schedule_delete <- renderUI({
    if (!is.null(input$my_calendar_delete)) {
      remove <- input$my_calendar_delete
      tags$div(
        "Schedule",
        tags$b(input$my_calendar_delete$id),
        "have been deleted with:",
        tags$ul(
          lapply(
            seq_along(remove),
            function(i) {
              tags$li(
                tags$b(names(remove)[i], ":"),
                remove[[i]]
              )
            }
          )
        )
      )
    }
  })
  
  # Update the calendar
  
  observeEvent(input$my_calendar_add, {
    # Add an id
    new_count <- schedule_count() + 1
    cal_proxy_add(
      proxy = "my_calendar",
      id = paste("schedule_", new_count),
      .list = input$my_calendar_add
    )
    schedule_count(new_count)
  })
  
  observeEvent(input$my_calendar_update, {
    cal_proxy_update(
      proxy = "my_calendar",
      .list = input$my_calendar_update
    )
  })
  
  observeEvent(input$my_calendar_delete, {
    cal_proxy_delete(
      proxy = "my_calendar",
      .list = input$my_calendar_delete
    )
  })
  
}

# Run the application
shinyApp(ui = ui, server = server)

Like this in edit mode, you can change the props affected to a specific schedule:

• Second option is to use a custom popup made in Shiny, so you can put whatever you want on it:

library(shiny)
library(tuicalendr)
library(shinyWidgets)


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")
)


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],
  body = paste("Body schedule", 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
)
schedules$raw <- lapply(
  X = seq_len(n),
  FUN = function(i) {
    list(status = sample(c("Completed", "In progress", "Closed"), 1)) # random status
  }
)




ui <- fluidPage(
  fluidRow(
    column(
      width = 8, offset = 2,
      tags$h2("Custom popover with HTML"),
      calendarOutput(outputId = "cal"),
      uiOutput("ui")
    )
  )
)

server <- function(input, output, session) {
  
  output$cal <- renderCalendar({
    calendar(defaultView = "month", taskView = TRUE, useDetailPopup = FALSE) %>% 
      # set_month_options(visibleWeeksCount = 2) %>%
      set_calendars_props_df(df = calendarProps) %>% 
      add_schedule_df(df = schedules) %>%
      set_events(
        clickSchedule = JS(
          "function(event) {", 
          "Shiny.setInputValue('calendar_id_click', {id: event.schedule.id, x: event.event.clientX, y: event.event.clientY});", 
          "}"
        )
      )
  })
  
  
  observeEvent(input$calendar_id_click, {
    removeUI(selector = "#calendar_panel")
    id <- as.numeric(input$calendar_id_click$id)
    # Get the appropriate line clicked
    sched <- schedules[schedules$id == id, ]
    
    insertUI(
      selector = "body",
      ui = absolutePanel(
        id = "calendar_panel",
        top = input$calendar_id_click$y,
        left = input$calendar_id_click$x, 
        draggable = FALSE,
        width = "300px",
        panel(
          status = "primary",
          actionLink(
            inputId = "close_calendar_panel", 
            label = NULL, icon = icon("close"), 
            style = "position: absolute; top: 5px; right: 5px;"
          ),
          tags$br(),
          tags$div(
            style = "text-align: center;",
            tags$p(
              "Here you can put custom", tags$b("HTML"), "elements."
            ),
            tags$p(
              "You clicked on schedule", sched$id, 
              "starting from", sched$start,
              "ending", sched$end
            ),
            tags$b("Current status:"), sched$raw[[1]]$status,
            radioButtons(
              inputId = "status",
              label = "New status:",
              choices = c("Completed", "In progress", "Closed"),
              selected = sched$raw[[1]]$status
            )
          )
        )
      )
    )
  })
  
  observeEvent(input$close_calendar_panel, {
    removeUI(selector = "#calendar_panel")
  })
  
  rv <- reactiveValues(id = NULL, status = NULL)
  observeEvent(input$status, {
    rv$id <- input$calendar_id_click$id
    rv$status <- input$status
  })
  
  output$ui <- renderUI({
    tags$div(
      "Schedule", tags$b(rv$id), "has been updated with status", tags$b(rv$status)
    )
  })
  
}

shinyApp(ui, server)

You can use whatever shiny logic you want, it's more flexible but require more code.

Hope it helps.

Victor

[pythiantech]

@pvictor thank you so much for this! I like the second approach better as it allows you more control and flexibility, though a bit heavy on writing custom code. But this is great, thanks again! Will let you know how it goes