...The problem is related to one of earlier post on insert and remove ui. I could solve the problem via shiny modules with the help of stack-overflow advice but faced problem while trying to bind a module generated table with an already existing table. The problem is that the rbinded table gets deleted as we delete the last row of the module generated table. I want to keep the preexisting table from the combined table even without the module generated table. Delete_Panels.pdf (96.3 KB)
The demo code
library(shiny)
library(dplyr)
library(ggplot2)
library(tidyverse)
Table to be combined with a user generated table derived from the panel values.
DT0 <- data.frame(event = c("Storm","Earthquake","Flood","Draught","Earthquake",
"Earthquake","Storm","Draught","Flood","Earthquake","Flood"),
state = c("Telangana","Arunachal Pradesh","Assam","Jharkhand","Delhi & NCR", "Himachal Pradesh","Jammu & Kashmir","Karnataka","Kerala","Mizoram","Nagaland"),
year = c(1980,1985,1985,1990,1990,1995,2000,2005,2010,2015,2020),
area = c(100, 200, 400, 500, 450,300,500,600,700,1700,2000),
money = c(1000,2000,3000,4000,5000,6000,10000,16000,20000,26000,32000))
Table used to build a querry table which will be joined later with the DT0 table from above.
DT1 <- data.frame(Year = c(1980,1985,1985,1990,1990,1995),
Events = c("Storm", "Earthquake", "Flood", "Draught",
"Earthquake", "Earthquake"),
Area_Loss = c(100, 200, 400, 500, 450,300),
Money = c(1000,2000,3000,4000,5000,6000))
##############################Module#############################
A module consists of all elements which belong together i.e. year, area, money and delete button
YAM_ui <- function(id) {
ns <- NS(id)
fluidRow(
id = id,
h3(id),
column(width = 3,
selectInput(ns("year"),
"Year",
DT$Year,
"")),
column(width = 4,
numericInput(ns("area"),
"Area",
0,
0,
10000,
1)),
column(width = 4,
numericInput(ns("money"),
"Money",
0,
0,
10000,
1)),
column(width = 1,
actionButton(ns("delete"), "Delete"))
)
}
-
we have multiple input reactive (events) which comes from the main app and
-
holds the value of the event and state selectInput
-
we return
-
a killSwitch to signal the main app to delete this module
-
a reactive which returns the data from all inputs organized in a data frame
YAM_server <- function(input, output, session,event,state){ killMe <- reactiveVal(FALSE) observe({ req(input$year) req(event()) updateNumericInput(session, "area", min = 0, max = 50000, value = DT1$Area_Loss[DT1$Year == input$year & DT1$Events == event()] , step = 0.1) updateNumericInput(session, "money", min = 0, max = 50000, value = DT1$Money[DT1$Year == input$year & DT1$Events == event()] , step = 0.1) }) get_data <- reactive({ req(!is.null(input$year), !is.null(input$area), !is.null(input$money), event(),state()) data.frame(event = event(), state = unique(state()$state), year = input$year, area = ifelse(input$area == "", NA, input$area), money = ifelse(input$money == "", NA, input$money)) }) observeEvent(input$delete, killMe(TRUE)) return(list(delete = killMe, get_data = get_data)) } #Main App ui <- fluidPage( titlePanel("Modules"), sidebarLayout( sidebarPanel( h4("Updating Inserted UIs"), selectInput("events", "Events", unique(DT$Events)), actionButton("add", "Add"), selectInput("state", "State", unique(DT0$state)), tableOutput("table") ), mainPanel( tags$div(id = "Panels"), plotOutput("plot") ) ) )
In the main App we have a reactive (handlers) which holds all reactives of all the modules
a list (observers) where we create (and delete) observers for the kill switch. When we add a row, we use insertUI to create the html and callModule to switch on the modules server logic. We pass the event reactive to the module to make it available within the module. When we observe a press to the delete button, we remove the handler from the lists and remove the corresponding html via removeUI. The data table is then updated automatically, because we removed the handler and it is not seen in the loop To get the table all we have to do is to loop through all handlers and call the get_data reactive from the modules to get the data.
server <- function(input, output, session) {
handlers <- reactiveVal(list())
observers <- list()
n <- 1
get_event <- reactive({
input$events
})
get_state <- reactive({
DF <- DT0
if(!is.null(input$state)){
DF1 <- DF[DF$state== input$state,]
}
DF1
})
observeEvent(input$add, {
id <- paste0(n)
n <<- n + 1
insertUI("#Panels",
"beforeEnd",
YAM_ui(id)
)
new_handler <- setNames(list(callModule(YAM_server,
id,
get_event,
get_state)),
id)
handler_list <- c(handlers(), new_handler)
handlers(handler_list)
})
observe({
hds <- handlers()
req(length(hds) > 0)
new <- setdiff(names(hds),
names(observers))
obs <- setNames(lapply(new, function(n) {
observeEvent(hds[[n]]$delete(), {
removeUI(paste0("#", n))
hds <- handlers()
hds[n] <- NULL
handlers(hds)
observers[n] <<- NULL
}, ignoreInit = TRUE)
}), new)
observers <<- c(observers, obs)
})
Table <- reactive({
hds <- req(handlers())
req(length(hds) > 0)
tbl_list <- lapply(hds, function(h) {
h$get_data()
})
do.call(rbind, tbl_list)
})
PROBLEM
- A reactive datafrme (Table) have been created from the values of get_data reactive
- and was attemted to rbind with an alraedy avialable dataframe (DT0) with a similar schema
- When we remove the last handler list and eventually the html via removeUI
- then the new combined table also disappears.
EXPECTED OUTPUT
- The DT0 table should remain intact even if we delete its rbind component i.e Table in my code
Tried to employ condition as follows which didin't work as expected
Condn_Tried <- reactive({
Table <- Table()
if(exists("Table")){
Combined_Table <<- rbind(DT0,Table)
}
else{
Combined_Table <<- DT0
}
})
Don't understand that if a table cease to exists due to the associated html removal then why the above condition is not working
Is there another way to achieve what I want to do in the above Condition
output$table <- renderTable({
Table <- Table()
Combined_Table <- rbind(DT0,Table)
# Condn_Tried()
})
Same Problem with the graph as the table and same is expected with the graph as well
output$plot <- renderPlot({
DF0 <- rbind(DT0,Table())
DF1 <- reshape2::melt(DF0,id.vars = c("event","state","year"),
measure.vars = c("area","money"))
p <- ggplot(DF1,aes(x= as.factor(DF1$year), y = DF1$value, fill = DF1$variable))+
geom_bar(stat = "identity", position = position_stack(), color = "black",width=0.7)+
scale_x_discrete(" ", limits = c(as.character(seq("1960", "2020"))), breaks =c(as.character(seq("1980", "2020", by = 5))))+
scale_y_continuous("Loss(In Rs)", expand = c(0,0), limits = c(0,NA))+
scale_fill_manual(values = c("blue","green"), labels = c("area","money"))+
scale_alpha_manual(values=c(1, .3))+
labs(fill = "")+
theme(aspect.ratio = 4/7)+
theme(axis.text.x = element_text(angle = 0, vjust = -0.5, size = 10, hjust = 0.5, color = "black",family = "Arial"),
axis.text.y = element_text(angle = 0, vjust = 0.4, size = 10, hjust = 1, color = "black",family = "Arial"),text = element_text(size=15,family = "Arial"),
axis.title.y = element_text(margin = margin(t=0, r= 20, b=0, l= 0),family = "Arial"))+
theme(legend.position= "right",legend.text=element_text(size=12,family = "Arial"),legend.key = element_rect(size = 0.01, color = NA, fill = NA),legend.key.size = unit(1, 'cm'))+
theme(panel.grid.major = element_line(size = 0.5, linetype = "dotted", color = "black"),
panel.border = element_blank(),panel.grid.minor = element_blank(),
axis.line = element_line(size = 0.5, linetype = "solid",colour = "black"), panel.spacing.y = unit(100, "inch"))
p
})
# In both the graph and table I would like to keep the DT0 even when Table() is not
present or is deleted
}
shinyApp(ui, server)
