日期输入 DT R shiny

Question

This is my code. Everything works fine.
DateInput is not visible in DT. Basically I wanted to get few items and two of them are dates. Date entry is working but when I press submit only Month data is coming not the dates. Similarly when I select a row and press delete the row is deleted. This is fine. But when I select a Row and press submit by mistake the app crashes.

I have the following query 1. Why Date Input is not working 2. Why my app crashes when I press submit after selecting a row

library(shiny)
library(shinyjs)
library(shinythemes)
library(DT)

GetMCATableMetadata <- function() {
  fields <- c(
    id = "Id",
    month = "Month of Account",
    due_date = "Due Date of Submission",
    actual_date = "Actual Date of Submission"
  )

  result <- list(fields = fields)
  return (result)
}


########################## CREATE, READ, UPDATE, DELETE #######################################
#### CRUD



# Find the next ID of a new record
GetMCANextId <- function() {
  if (exists("mcaresponses") && nrow(mcaresponses) > 0) {
    max(as.integer(rownames(mcaresponses))) + 1
  } else {
    return (1)
  }
}

#C
CreateData <- function(data) {
  data <- CastData(data)
  rownames(data) <- GetMCANextId()
  if (exists("mcaresponses")) {
    mcaresponses <<- rbind(mcaresponses, data)
  } else {
    mcaresponses <<- data
  }
}

#R
ReadData <- function() {
  if (exists("mcaresponses")) {
    mcaresponses
  }
}

#U
UpdateData <- function(data) {
  data <- CastData(data)
  mcaresponses[row.names(mcaresponses) == row.names(data),] <<- data
}

#D
DeleteData <- function(data) {
  mcaresponses <<-
    mcaresponses[row.names(mcaresponses) != unname(data["id"]),]
}

#######################################################################################
# Cast from Inputs to a one-row data.frame

CastData <- function(data) {
  datar <- data.frame(
    month = data["month"],
    due_date = as.Date(data[["due_date"]],"dd-mm-yyyy"),
    actual_date = as.Date(data[["actual_date"]],"dd-mm-yyyy")
  )

  rownames(datar) <- data["id"]
  return (datar)
}




# Return an empty, new record
CreateDefaultRecord <- function() {
  mydefault <-
    CastData(list(
      id = "0",
      month = "", 
      due_date ="",
      actual_date=""

    ))
  return (mydefault)
}

# Fill the input fields with the values of the selected record in the table
UpdateInputs <- function(data, session) {
  updateTextInput(session, "id", value = unname(rownames(data)))
  updateTextInput(session, "month", value = unname(data["month"]))
  updateDateInput(session, "due_date", value = as.Date(data[["due_date"]],"dd-mm-yyyy"))
  updateDateInput(session, "actual_date",value=as.Date(data[["actual_date"]],"dd-mm-yyyy"))

}



ui <- fluidPage(
  #use shiny js to disable the ID field
  shinyjs::useShinyjs(),
  ##
  #data table
  DT::dataTableOutput("mcaresponses", width = 800),

  #input fields
  tags$hr(),
  shinyjs::disabled(textInput("id", "Id", "0")),
  textInput("month", "Month of Account", ""),
  dateInput("due_date", label="Due Date of Submission", format="dd-mm-yyyy"),
  dateInput("actual_date", label="Actual Date of Submission", format="dd-mm-yyyy"),
  #action buttons
  actionButton("submit", "Submit"),
  actionButton("new", "New"),
  actionButton("delete", "Delete")
)



server <- function(input, output, session) {
  # input fields are treated as a group
  formData <- reactive({
    sapply(names(GetMCATableMetadata()$fields), function(x)
      input[[x]])
  })

  # Click "Submit" button -> save data
  observeEvent(input$submit, {
    if (input$id != "0") {
      UpdateData(formData())
    } else {
      CreateData(formData())
      UpdateInputs(CreateDefaultRecord(), session)
    }
  }, priority = 1)

  # Press "New" button -> display empty record
  observeEvent(input$new, {
    UpdateInputs(CreateDefaultRecord(), session)
  })

  # Press "Delete" button -> delete from data
  observeEvent(input$delete, {
    DeleteData(formData())
    UpdateInputs(CreateDefaultRecord(), session)
  }, priority = 1)

  # Select row in table -> show details in inputs
  observeEvent(input$mcaresponses_rows_selected, {
    if (length(input$mcaresponses_rows_selected) > 0) {
      data <- ReadData()[input$mcaresponses_rows_selected,]
      UpdateInputs(data, session)
    }

  })

  # display table
  output$mcaresponses <- DT::renderDataTable({
    #update after submit is clicked
    input$submit
    #update after delete is clicked
    input$delete
    ReadData()
    }, server = FALSE, selection = "single",
  colnames = unname(GetMCATableMetadata()$fields)[-1])

}

shinyApp(ui = ui, server = server)

Answer 1

I think much of the challenge here is the date format. When you call:

sapply(names(GetMCATableMetadata()$fields), function(x) input[[x]])

The values stored is a numeric value (in a string).

You can convert this to a date in CastData :

due_date = as.Date(as.numeric(data["due_date"]), origin = "1970-01-01"),
actual_date = as.Date(as.numeric(data["actual_date"]), origin = "1970-01-01")

When you update the DateInput for due_date and actual_date you already will have a Date format:

updateDateInput(session, "due_date", value = data[["due_date"]], "dd-mm-yyyy")
updateDateInput(session, "actual_date", value = data[["actual_date"]],"dd-mm-yyyy")

There may be some alternative approaches, but this seems to work with current setup to create, select row, and delete. Let me know if this works for you.