Shiny CRUD App with DateInputs

31 views
Skip to first unread message

John Magrini

unread,
Jun 22, 2017, 11:59:37 AM6/22/17
to Shiny - Web Framework for R
Hello all,

I am looking for some assistance regarding using a dateInput in a CRUD app. I used the source code from the iPub blog post about CRUD Shiny Apps : https://ipub.com/shiny-crud-app/

I've been trying to modify the code so that there is a dateInput. I was able to get the format to be a date but it will only show the current date even when you change the input. The solve on that code does not work on the sample code below and this will also demo that the date will not change.

I'm getting only characters instead of a date format and it is the same characters/dates regardless of what is selected via the input. Forgive my density if there is a better protocol for sharing things but I'm in a bit of pinch and would really appreciate some help on getting this resolved.

Thanks in advance!



library(shiny)
library(shinyjs)


# Get table metadata. For now, just the fields
# Further development: also define field types
# and create inputs generically
GetTableMetadata <- function() {
  fields <- c(id = "Id", 
              name = "Name", 
              used_shiny = "Used Shiny", 
              date_started = "Date Started")
  
  result <- list(fields = fields)
  return (result)
}

# Find the next ID of a new record
# (in mysql, this could be done by an incremental index)
GetNextId <- function() {
  if (exists("responses") && nrow(responses) > 0) {
    max(as.integer(rownames(responses))) + 1
  } else {
    return (1)
  }
}

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

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



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

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




# Cast from Inputs to a one-row data.frame
CastData <- function(data) {
  datar <- data.frame(name = data["name"], 
                      used_shiny = as.logical(data["used_shiny"]), 
                      date_started = as.Date(data["date_started"]),
                      stringsAsFactors = FALSE)
  
  rownames(datar) <- data["id"]
  return (datar)
}




# Return an empty, new record
CreateDefaultRecord <- function() {
  mydefault <- CastData(list(id = "0", name = "", used_shiny = FALSE, date_started = Sys.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, "name", value = unname(data["name"]))
  updateCheckboxInput(session, "used_shiny", value = as.logical(data["used_shiny"]))
  updateTextInput(session, "date_started", value = Sys.Date())
}


ui <- fluidPage(
  #use shiny js to disable the ID field
  shinyjs::useShinyjs(),
  
  #data table
  DT::dataTableOutput("responses", width = 300), 
  
  #input fields
  tags$hr(),
  shinyjs::disabled(textInput("id", "Id", "0")),
  textInput("name", "Name", ""),
  checkboxInput("used_shiny", "Used Shiny", FALSE),
  dateInput("date_started", "Date Started"),
  
  #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(GetTableMetadata()$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$responses_rows_selected, {
    if (length(input$responses_rows_selected) > 0) {
      data <- ReadData()[input$responses_rows_selected, ]
      UpdateInputs(data, session)
    }
    
  })
  
  # display table
  output$responses <- DT::renderDataTable({
    #update after submit is clicked
    input$submit
    #update after delete is clicked
    input$delete
    ReadData()
  }, server = FALSE, selection = "single",
  colnames = unname(GetTableMetadata()$fields)[-1]
  )     
  
  
  
}


# Shiny app with 3 fields that the user can submit data for
shinyApp(ui = ui, server = server)

John Magrini

unread,
Jun 22, 2017, 12:01:16 PM6/22/17
to Shiny - Web Framework for R

John Magrini

unread,
Jun 22, 2017, 10:12:12 PM6/22/17
to Shiny - Web Framework for R
I changed the date inputs to text inputs, made the format clear in the labels and defaulted to as.character(Sys.Date()) which will sort of work for now. I'll have to deal with fat finger entries another way.


On Thursday, June 22, 2017 at 10:59:37 AM UTC-5, John Magrini wrote:
Reply all
Reply to author
Forward
0 new messages