Hello, I am trying to create a contacts database with shiny modules and I have run into a bit of a snag. The following code is my global, modules, and shiny code. The submit, and new buttons work fine. (I am S3 as storage for the DB), but it does not appear to be recognizing the delete button at all. Would you please advise? Thank you in advance for your help.
contact_modules.R
GetTableMetadata <- function() {
fields <- c(
id = "Id",
first = "First",
last = "Last",
email = "Email",
phone = "Phone",
work = "Work",
company = "Company"
)
results <- list(fields = fields)
return(results)
}
# Find the next ID of a new record
# (in mysql, this could be done by an incremental index)
GetNextId <- function() {
if (exists("contacts") && nrow(contacts) > 0) {
max(as.integer(rownames(contacts))) + 1
} else {
return(1)
}
}
#C
CreateData <- function(data) {
data <- CastData(data)
rownames(data) <- GetNextId()
if (exists("contacts")) {
contacts <<- rbind(contacts, data)
} else {
contacts <<- data
}
s3save(contacts, bucket = "", object = "contacts.Rds")
}
#R
ReadData <- function() {
s3load("contacts.Rds", bucket = "")
return(contacts)
}
#U
UpdateData <- function(data) {
data <- CastData(data)
contacts[rownames(contacts) == rownames(data), ] <<- data
s3save(contacts, bucket = "", object = "contacts.Rds")
}
#D
DeleteData <- function(data) {
contacts <<- contacts[rownames(contacts) != unname(data["id"]), ]
s3save(contacts, bucket = "", object = "contacts.Rds")
}
# Cast from Inputs to a one-row data.frame
CastData <- function(data) {
result <- data.frame(first = data["first"],
last = data["last"],
email = data["email"],
phone = data["phone"],
work = data["work"],
company = data["company"],
stringsAsFactors = FALSE)
rownames(result) <- data["id"]
return(result)
}
# Return an empty, new record
CreateDefaultRecord <- function() {
mydefault <- CastData(list(id = "0", first = "", last = "",
email = "", phone = "", work = "",
company = ""))
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, "first", value = unname(data["first"]))
updateTextInput(session, "last", value = unname(data["last"]))
updateTextInput(session, "email", value = unname(data["email"]))
updateTextInput(session, "phone", value = unname(data["phone"]))
updateTextInput(session, "work", value = unname(data["work"]))
updateTextInput(session, "company", value = unname(data["company"]))
}
Modules
contact_UI <- function(id) {
ns <- shiny::NS(id)
tagList(
sidebarLayout(
sidebarPanel(width = 3,
shinyjs::disabled(textInput(ns("id"), "Id", "0")),
textInput(ns("first"), label = "First", value = ""),
textInput(ns("last"), label = "Last", value = ""),
textInput(ns("email"), label = "Email", value = ""),
textInput(ns("phone"), label = "Phone", value = ""),
textInput(ns("work"), label = "Work", value = ""),
textInput(ns("company"), label = "Company", value = ""),
tags$hr(),
#action buttons
actionButton(ns("submit"), "Submit"),
actionButton(ns("new"), "New"),
actionButton(ns("delete"), "Delete")
),
mainPanel(
DTOutput(ns("contact.db"))
))
)
}
contact <- function(input, output, session, data) {
# input fields are treated as a group
formData <- reactive({
sapply(names(GetTableMetadata()$fields), function(x) input[[x]])
})
observeEvent(input$submit, {
sendSweetAlert(
session = session,
title = "Sweet!",
text = "Contact submitted",
type = "success",
closeOnClickOutside = TRUE
)
})
# 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)
})
observeEvent(input$delete, {
confirmSweetAlert(
session = session,
inputId = "deleted",
type = "warning",
title = "Do you really want to delete this contact?",
danger_mode = TRUE
)
}, priority = 1)
# Press "Delete" button -> delete from data
observeEvent(input$deleted, {
if (isTRUE(input$deleted)) {
DeleteData(formData())
UpdateInputs(CreateDefaultRecord(), session)
} else {
NULL
}
}, priority = 1)
# Select row in table -> show details in inputs
observeEvent(input$contact.db_rows_selected, {
if (length(input$contact.db_rows_selected) > 0) {
data <- ReadData()[input$contact.db_rows_selected, ]
UpdateInputs(data, session)
}
})
# display table
output$contact.db <- DT::renderDT({
#update after submit is clicked
input$submit
#update after delete is clicked
input$deleted
ReadData()
}, server = FALSE, selection = "single", filter = "top", extensions = c('Buttons', 'Responsive'),
options = list(dom = "Bfrtip", searchHighlight = TRUE, autoWidth = TRUE,
buttons = c('copy', 'csv', 'excel')),
rownames = FALSE, colnames = unname(GetTableMetadata()$fields)[-1])
}
app.R
library(shiny)
library(aws.s3)
library(tidyverse)
library(DT)
library(shinyWidgets)
library(shinythemes)
source("contact_module.R")
# Define UI for application
ui <- fluidPage(theme = shinytheme("spacelab"),
# Application title
titlePanel("Contact Database"),
shinyjs::useShinyjs(),
contact_UI("first.db")
)
# Define server logic required
server <- function(input, output, session) {
shiny::callModule(contact, "first.db")
}
# Run the application
shinyApp(ui = ui, server = server)