In my app there are multiple data frames, each corresponding to only one value in a selectizeinput. When the selectizeinput value matches the table's name, the correct data frame is linked to an rhandsontable. There is only one rhandsontable, which is shared by all of the underlying data frames but never at the same time. Users make edits to the selected data frame via the rhandsontable. These edits are saved when a button is clicked. In the example below I have an observeEvent that triggers a save to one of the data frames. This is an issue because if another data frame is selected and edited, the save button will save the values to the other table, not the currently selected one. I know that if else statements, like what I have for swapping in and out the dataframes, within the observeEvent will throw up an argument of zero length. I knew ahead of time that the current observeEvent approach would cause the issue of saving to the wrong table but I wanted to get a partially functional example to begin working with.
Working example:
library(shiny)
library(shinyWidgets)
library(tidyverse)
library(DBI)
library(RPostgres)
library(bslib)
library(data.table)
library(rhandsontable)
library(shinyauthr)
library(sodium)
library(rsconnect)
#set up fake usernames and passwords for this working example
user_base <- tibble::tibble(
user = c("test"),
password = sapply(c("test"),
sodium::password_store),
permissions = c("test"),
name = c("test")
)
#USER INTERFACE
ui <- fluidPage(
#boostrap theme and header logo/title
theme = bs_theme(version = 5, bootswatch = "lumen"),
#log out button
br(),
div(class = "float-right", shinyauthr::logoutUI(id = "logout")),
br(),
br(),
#login section
shinyauthr::loginUI(id ="login"),
#show the full view of the app after login
uiOutput("fullview"),
) #fluid ui end
#SERVER FUNCTIONS
server <- function(input, output, session) {
#Query Postgres and ingest needed tables into reactive environment
# alignment_aim <- dbReadTable(conn = con,"ta_plan_aim")
#create a function to handle credentials
credentials <- shinyauthr::loginServer(
id = "login",
data = user_base,
user_col = user,
pwd_col = password,
sodium_hashed = TRUE,
log_out = reactive(logout_init())
)
# Logout to hide
logout_init <- shinyauthr::logoutServer(
id = "logout",
active = reactive(credentials()$user_auth)
)
#render ui
output$fullview <- renderUI({
req(credentials()$user_auth)
navbarPage(
title=("PaTTAN Training Plan Management System"),
tabPanel("Home", #matrix1
sidebarLayout(
sidebarPanel(
),
mainPanel(
)
)
),
tabPanel("Create and Modify Training Plans",
sidebarLayout(
sidebarPanel(
width = 2,
h4(strong("Directions")),
p("[Insert directions about how to create, modify
and view the training plans]"
,style = "font-size:13px"),
selectizeInput("initiative_selector",
h5(strong("Component Plan")),
choices = list(
"Accessible Instructional Materials (AIM) Center",
"Alternate Education for Disruptive Youth",
"Assistive Technology",
"Autism",
"Blind - Visual Impairment",
"Corrections",
"Deaf-Blind",
"Deaf and Hard of Hearing",
"Family Engagement",
"Inclusive Practices",
"Intensive Interagency",
"Learning Environment and Engagement",
"Literacy",
"Math",
"MTSS/RtI Academics",
"MTSS English Learners",
"MTSS Equity",
"Paraprofessionals",
"Publications",
"School Psychologist",
"Secondary Transition",
"Significant Cognitive Disabilities",
"Special Education Law",
"Special Education Leadership",
"Speech & Language",
"State Personnel Development Grant",
"State Systemic Improvement Plan",
"Increasing Graduation Rates/ Decreasing Dropout Rates",
"STEM/Computer Science",
"Supporting Students with Disabilities in Virtual Environments"
)
),
p("You can type the name of the intitiative to filter and
select it from the drop down menu above. Use backspace
within the white box to delete your typed text.",
style = "font-size:13px;"),
selectizeInput("Office_Selector",
h5(strong("Select Lead Office for Intitative")),
choices = list(
"test",
"test2")
),
selectizeInput("State_lead_select",
h5(strong("Select State Leads for Intitative")),
multiple = TRUE,
choices = list(
"test",
"test2"
)
),
p("Click the blank box above to select a lead or co-leads.
A menu will appear. Use the backspace key to delete one
or more of your choices",
style = "font-size:13px;"),
br(),
actionButton("save","Save Edits"),
br(),
br(),
downloadLink("download_plan",h5("Download Plan"))
),
mainPanel(
tabsetPanel(
tabPanel("Create / Update Projects",
h3(strong("Implementation Alignment")),
rHandsontableOutput('alignment'),
),
tabPanel("Projects Overview"),
)#end of tabsetPanel
) #main panel end
) #sidebar layout end
) #end tab panel for create / edit plans
) #Navbar end
})
# save user edited values back to alignment tables
observeEvent(input$save,{
alignment_aim <<- hot_to_r(input$alignment)
})
#configure ui server functions
output$alignment <- renderRHandsontable({
rhandsontable(
if (input$initiative_selector =="Accessible Instructional Materials (AIM) Center"){
alignment_aim
} else if
(input$initiative_selector =="Alternate Education for Disruptive Youth") {
alignment_alt_ed_dis_yth
} else if (input$initiative_selector =="Assistive Technology") {
alignment_assitive_tech
} else if (input$initiative_selector =="Autism") {
alignment_autism
} else if (input$initiative_selector =="Blind - Visual Impairment") {
alignment_blind_vi
}
,rowHeaders = FALSE) %>%
hot_table(stretchH = "all") %>%
hot_table(highlightCol = TRUE, highlightRow = TRUE) %>%
hot_context_menu(allowRowEdit=FALSE)
})
output$download_plan <- downloadHandler(
filename = function() {
paste("PDE_Training_Plan-",input$initiative_selector,"-",Sys.Date(),".csv",sep="")
},
content = function(file){
write.csv(hot_to_r(input$alignment),file,row.names = TRUE)
}
)
#debugging alignment matrix
# observeEvent(input$alignment, {
# # test_df = hot_to_r(input$alignment)
# print(alignment_aim)
# })
#
# observeEvent(input$alignment, {
# test_df = hot_to_r(input$alignment)
# column6 <- test_df[,6]
# print(column6)
# })
} #end of server function
# Run the application
shinyApp(ui = ui, server = server)
Use the following to make example, empty data frames so that the app can run. I've only included a few from the selectinput.
alignment_aim <- data.table(
Components = c("LRE (A)","High Incidence (B)",
"Low Incidence (C)","Equitable Practices (D)",
"Pillar Measues","Pillar Outcomes"),
attract_prep_retain = rep(c(""),6),
fam_engagement = rep(c(""),6),
sec_trans = rep(c(""),6),
instruct_dev = rep(c(""),6),
Learning_Env_Eng = rep(c(""),6),
component_measures = rep(c(""),6)
)
alignment_alt_ed_dis_yth <- data.table(
Components = c("LRE (A)","High Incidence (B)",
"Low Incidence (C)","Equitable Practices (D)",
"Pillar Measues","Pillar Outcomes"),
attract_prep_retain = rep(c(""),6),
fam_engagement = rep(c(""),6),
sec_trans = rep(c(""),6),
instruct_dev = rep(c(""),6),
Learning_Env_Eng = rep(c(""),6),
component_measures = rep(c(""),6)
)
alignment_assitive_tech <- data.table(
Components = c("LRE (A)","High Incidence (B)",
"Low Incidence (C)","Equitable Practices (D)",
"Pillar Measues","Pillar Outcomes"),
attract_prep_retain = rep(c(""),6),
fam_engagement = rep(c(""),6),
sec_trans = rep(c(""),6),
instruct_dev = rep(c(""),6),
Learning_Env_Eng = rep(c(""),6),
component_measures = rep(c(""),6)
)
alignment_autism <- data.table(
Components = c("LRE (A)","High Incidence (B)",
"Low Incidence (C)","Equitable Practices (D)",
"Pillar Measues","Pillar Outcomes"),
attract_prep_retain = rep(c(""),6),
fam_engagement = rep(c(""),6),
sec_trans = rep(c(""),6),
instruct_dev = rep(c(""),6),
Learning_Env_Eng = rep(c(""),6),
component_measures = rep(c(""),6)
)
alignment_blind_vi <- data.table(
Components = c("LRE (A)","High Incidence (B)",
"Low Incidence (C)","Equitable Practices (D)",
"Pillar Measues","Pillar Outcomes"),
attract_prep_retain = rep(c(""),6),
fam_engagement = rep(c(""),6),
sec_trans = rep(c(""),6),
instruct_dev = rep(c(""),6),
Learning_Env_Eng = rep(c(""),6),
component_measures = rep(c(""),6)
)
UPDATE:
Isolating input$intitiative_selector is the fix
observeEvent(input$save,{
if (isolate(input$initiative_selector) =="Accessible Instructional Materials (AIM) Center"){
alignment_aim <<- hot_to_r(input$alignment)
}
})
