【发布时间】：2022-01-28 05:00:29
【问题描述】：
在我的应用中有多个数据框，每个数据框只对应一个 selectizeinput 中的一个值。当 selectizeinput 值与表的名称匹配时，正确的数据框将链接到 rhandsontable。只有一个 rhandsontable，它由所有底层数据帧共享，但不会同时共享。用户通过 rhandsontable 对选定的数据框进行编辑。单击按钮时会保存这些编辑。在下面的示例中，我有一个 observeEvent 触发保存到其中一个数据帧。这是一个问题，因为如果选择并编辑了另一个数据框，则保存按钮会将值保存到另一个表，而不是当前选择的表。我知道如果 else 语句，比如我用于交换数据帧的语句，在 observeEvent 中会抛出一个零长度的参数。我提前知道当前的 observeEvent 方法会导致保存到错误表的问题，但我想获得一个部分功能的示例来开始使用。
工作示例：
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)
使用以下示例，清空数据框以便应用程序可以运行。我只从 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)
)
更新：
隔离 input$intitiative_selector 是解决方法
observeEvent(input$save,{
if (isolate(input$initiative_selector) =="Accessible Instructional Materials (AIM) Center"){
alignment_aim <<- hot_to_r(input$alignment)
}
})
【问题讨论】：
标签： shiny reactive selectinput action-button