In my shiny app I have a dynamic input using renderUI.
This works very well, and another part of the program captures the input of the sliders.
When the application changes of status (e.g. when the button "update model" is pressed) I still need to display / use sliders with similar labels but as they are "new" the value needs to be re-initialised to zero.
The problem is that the sliders have a memory. If I re-use the same inputId
paste0(Labv[i], "_v",buttn)
shiny will have the old value associated to it.
Currently my code is using the variable buttn to bypass the problem: every time the status changes I create "new" sliders.
On the other hand the more the users will use the app, the more garbage will be collected into shiny.
I tried to use renderUI to send the list of elements to NULL, experimenting with sending a list of
updateTextInput(session, paste0(lbs[i],"_v",buttn),
label = NULL, value = NULL )
or tags$div("foo", NULL) but in each case the actual variable was rendered as text, which is worst!
# Added simplified example
library(shiny)
library(data.table)
#
dt_ = data.table( Month = month.abb[1:5],
A=rnorm(5, mean = 5, sd = 4),
B=rnorm(5, mean = 5, sd = 4),
C=rnorm(5, mean = 5, sd = 4),
D=rnorm(5, mean = 5, sd = 4),
E=rnorm(5, mean = 5, sd = 4))
dt_[,id :=.I]
dt <- copy(dt_)
setkey(dt_, "Month")
setkey(dt, "Month")
shinyApp(
ui = fluidPage(
fluidRow(
column(4,
actionButton("saveButton", "Update Model"))),
fluidRow(
column(6, dataTableOutput('DT')),
column(3, br(),br(),checkboxGroupInput("pick",h6("Picker"),
month.abb[1:5])),
column(3, uiOutput('foo'))),
fluidRow(
column(4, verbatimTextOutput('vals')))
),
server = function(session,input, output) {
valPpu <- reactiveValues()
valPpu$buttonF <- 1
valPpu$dt_ <- dt_
##
output$DT <- renderDataTable({
if(length(input$pick) > 0 ) {
# browser()
isolate( { labs <- input$pick } ) #
buttn <- valPpu$buttonF
iter <- length(labs)
valLabs <- sapply(1:iter, function(i) {
as.numeric(input[[paste0(labs[i],"_v",buttn)]]) })
if( iter == sum(sapply(valLabs,length)) ) {
cPerc <- valLabs
cPerc <- as.data.table(cPerc)
cPercDt <- cbind(Month=labs,cPerc)
ival <- which(dt[["Month"]]
%in% cPercDt[["Month"]])
setkey(cPercDt, "Month")
for(j in LETTERS[1:5]) set(dt_, i=ival,
j=j, dt[cPercDt][[j]] * (1 + dt_[cPercDt][["cPerc"]]) )
valPpu$dt_ <- dt_
} }
dt_[order(id),]
}, options = list(
scrollX = TRUE,
scrollY = "250px" ,
scrollCollapse = TRUE,
paging = FALSE,
searching = FALSE,
ordering = FALSE )
)
##
output$foo <- renderUI({
if(is.null(input$saveButton)) { return() }
if(length(input$pick) > 0 ) {
labs <- input$pick
iter <- length(labs)
buttn <- isolate(valPpu$buttonF )
valLabs <- sapply(1:iter, function(i) {
if(is.null(input[[paste0(labs[i],"_v",buttn)]] )) {
0
} else { as.numeric(input[[paste0(labs[i],"_v",buttn)]]) }
})
#
toRender <- lapply(1:iter, function(i) {
sliderInput(inputId = paste0(labs[i], "_v",buttn),
label = h6(paste0(labs[i],"")),
min = -1,
max = 1,
step = 0.01,
value = valLabs[i],
# format = "##0.#%",
ticks = FALSE, animate = FALSE)
})
toRender
}
})
observe({
if(is.null(input$saveButton)) { return() }
if(input$saveButton < valPpu$buttonF) { return() }
valPpu$buttonF <- valPpu$buttonF + 1
dt <<- valPpu$dt_
# TODO: add proper saving code
})
}
)
In the actual app the checkboxGroupInput is also driven from the server with renderUI and is reset when the "update model" is pressed. Also, there are more "events" in the UI that I haven't added to the code.
Any idea?
So your current approach actually works. FWIW, the sliders have been removed from HTML, so you do not need to worry about that. For the old values stored in input, such as input[['Jan_v1']] when the button has been clicked twice (and you only need input[['Jan_v2']]), I do not see why you care so much about them unless your total memory is less than a few kilobytes, because you only need a few bytes to store these values. It is probably true that you cannot remove these values from input, but I'd suggest you not spend time on this issue until it becomes a real problem.
Related
Consider this function:
fx <- function(x) {
sapply(X = x, FUN = function(x) {
if (x > 1) {
NULL
} else (x)
})
}
And this data:
set.seed(5)
df_1 <- data.frame(x = replicate(n = 5, expr = runif(n = 5, min = 0, max = 1.7)))
Now, I apply the function to a column of this data:
fx(df_1[,1])
And now, I apply the function in one line.
fx(df_1[1,])
However, when I try to apply this inside reactiveValues I can't get it to work. I think I'm putting it incorrectly inside observeEvent.
I would like that, when the user enters values greater than 1 (either in a row or in a column or both selected), the cell is empty again, just like when typing a text (you can test by writing a text in it and you will see that it becomes empty).
My DT:
library(shiny)
library(shinydashboard)
library(tidyverse)
header <- dashboardHeader(title = "Dash", titleWidth = 250)
sidebar <- dashboardSidebar(sidebarMenu(menuItem(text = "Testar", tabName = "test")))
body <- dashboardBody(
tabItems(
tabItem(
tabName = "test",
titlePanel("Tabela"),
fluidPage(
column(
width = 3,
DT::dataTableOutput("my_datatable")
)
)
)
)
)
ui <- dashboardPage(header, sidebar, body)
server <- function(input, output) {
v <- reactiveValues(data = {
data.frame(y = rep(NA, 30), x = rep(NA, 30))
})
output$my_datatable <- DT::renderDataTable({
DT::datatable(
data = v$data,
editable = TRUE,
rownames = TRUE,
selection = list(mode = 'none'),
options = list(
searching = FALSE,
paging = FALSE,
ordering = FALSE,
info = FALSE,
autoWidth = TRUE
)
)
})
observeEvent(input$my_datatable_cell_edit, {
info = input$my_datatable_cell_edit
i = as.numeric(info$row)
j = as.numeric(info$col)
k = as.numeric(info$value)
# converter positivos em negativos (se character, o resultado e NULL)
if (!is.na(k) & k < 0) {
k <- k * -1
} else (k)
v$data[i, j] <- k
})
}
shinyApp(ui, server)
The function I wrote at the beginning of this question I used inside the observeEvent, below this one:
if (!is.na(k) & k < 0) {
k <- k * -1
} else (k)
Which works perfectly (and I want to keep it). But, I'd like to add some additional conditions on specific columns and rows, something I haven't been able to do (every time I tried, DT crashed and the app crashed).
The are two issues with your function which result in an error. First, you replace value by NULL so your function returns a list instead of a vector. Second, your function does not account of NAs in the data table, i.e. as you loop over the vector elements each NA element will give rise to an error when checking if (x > 1). Actually you could rewrite your function more concise and without running in these issues like so:
fx <- function(x) {
x[x > 1] <- NA
x
}
Note: IMHO there is no need for a function which replaces values in a row or column. As the user enters the values per cell it's sufficient to check whether the inputted value is larger than one and replace it with NA in case it is, i.e. you could use if (k > 1) k <- NA instead.
fx <- function(x) {
x[x > 1] <- NA
x
}
library(shiny)
library(shinydashboard)
header <- dashboardHeader(title = "Dash", titleWidth = 250)
sidebar <- dashboardSidebar(sidebarMenu(menuItem(text = "Testar", tabName = "test")))
body <- dashboardBody(
tabItems(
tabItem(
tabName = "test",
titlePanel("Tabela"),
fluidPage(
column(
width = 3,
DT::dataTableOutput("my_datatable")
)
)
)
)
)
ui <- dashboardPage(header, sidebar, body)
server <- function(input, output) {
v <- reactiveValues(data = {
data.frame(y = rep(NA, 30), x = rep(NA, 30))
})
output$my_datatable <- DT::renderDataTable({
DT::datatable(
data = v$data,
editable = TRUE,
rownames = TRUE,
selection = list(mode = "none"),
options = list(
searching = FALSE,
paging = FALSE,
ordering = FALSE,
info = FALSE,
autoWidth = TRUE
)
)
})
observeEvent(input$my_datatable_cell_edit, {
info <- input$my_datatable_cell_edit
i <- as.numeric(info$row)
j <- as.numeric(info$col)
k <- as.numeric(info$value)
if (!is.na(k) && k < 0) {
k <- k * -1
}
v$data[i, j] <- k
v$data[i, ] <- fx(v$data[i, ])
})
}
shinyApp(ui, server)
I understand similar questions have been asked and I've tried virtually every solution with no luck.
In my application, I've allowed the user to modify individual cells of a DT::datatable. The source of the datatable is a reactive data frame.
After the user makes changes to the clientside datatable, the datatable source is remains unchanged. This is an issue as later on, when I allow the user to add rows to the data table, the row is added onto the source datatable where the clientside datatable then reflects this change. However, this means that if the user makes a change to a cell in the clientside datatable, when the user adds a row to the same table, the change made by the user will be forgotten as it was never made to the source.
I've tried many ways to update the underlying/serverside datatable with no luck. editData keeps giving me errors/NA. I also have tried indexing the serverside table and placing the changed value inside of it, with no luck. I'll post my code below with some comments for specifics..
library(shiny)
library(DT)
library(data.table)
source('~/camo/camo/R/settings.R')
source('~/camo/camo/etl.R')
# Define UI ----
ui <- fluidPage(
titlePanel("PAlpha"),
mainPanel(
fluidRow(
tabsetPanel(id = 'tpanel',
type = "tabs",
tabPanel("Alpha", plotOutput("plot1")),
tabPanel("Beta", plotOutput("plot2")),
tabPanel("Charlie", plotOutput("plot3")),
tabPanel("Delta", plotOutput("plot4")))
),
fluidRow(
splitLayout(
dateInput("sdate", "Start Date"),
dateInput("edate", "End Date"),
textInput("gmin", "Global Minimum"),
textInput("gmax", "Global Maximum")
)
),
fluidRow(
splitLayout(
textInput("groupInp", NULL, placeholder = "New Group"),
actionButton("addGrpBtn", "Add Group"),
textInput("tickerInp", NULL, placeholder = "New Ticker"),
actionButton("addTickerBtn", "Add Ticker")
)
),
fluidRow(
splitLayout(
DT::dataTableOutput('groupsTable'),
DT::dataTableOutput('groupTickers')
),
verbatimTextOutput("print")
)
)
)
# Define server logic ----
server <- function(input, output) {
port_proxy <- dataTableProxy('groupsTable')
rv <- reactiveValues(
portfolio = data.frame('Group' = c('Portfolio'), 'Minimum Weight' = c(0), 'Maximum Weight' = c(0), 'Type' = c('-')),
groups = list(group1 = data.frame('Group' = c('Ticker'), 'Minimum Weight' = c(0), 'Maximum Weight' = c(0), 'Type' = c('-'))),
deletedRows = NULL,
deletedRowIndices = list()
)
output$groupsTable <- DT::renderDataTable(
# Add the delete button column
deleteButtonColumn(rv$portfolio, 'delete_button')
)
output$print <- renderPrint({
rv$portfolio
})
############## LISTENERS ################
observeEvent(input$deletePressed, {
rowNum <- parseDeleteEvent(input$deletePressed)
dataRow <- rv$portfolio[rowNum,]
# Put the deleted row into a data frame so we can undo
# Last item deleted is in position 1
rv$deletedRows <- rbind(dataRow, rv$deletedRows)
rv$deletedRowIndices <- append(rv$deletedRowIndices, rowNum, after = 0)
# Delete the row from the data frame
rv$portfolio <- rv$portfolio[-rowNum,]
})
observeEvent(input$addGrpBtn, {
row <- data.frame('Group' = c(input$groupInp),
'Minimum Weight' = c(0),
'Maximum Weight' = c(0),
'Type' = c('-'))
rv$portfolio <- addRowAt(rv$portfolio, row, nrow(rv$portfolio))
})
observeEvent(input$groupsTable_cell_edit,{
info <- str(input$groupsTable_cell_edit)
i <- info$row
j <- info$col
v <- info$value
rv$portfolio <- editData(rv$portfolio, input$groupsTable_cell_edit) # doesn't work see below
# Warning in DT::coerceValue(v, data[i, j, drop = TRUE]) :
# New value(s) "test" not in the original factor levels: "Portfolio"; will be coerced to NA.
# rv$portfolio[i,j] <- input$groupsTable_cell_edit$value
# rv$portfolio[i,j] <- v #doesn't work
})
}
addRowAt <- function(df, row, i) {
# Slow but easy to understand
if (i > 1) {
rbind(df[1:(i - 1), ], row, df[-(1:(i - 1)), ])
} else {
rbind(row, df)
}
}
deleteButtonColumn <- function(df, id, ...) {
# function to create one action button as string
f <- function(i) {
# https://shiny.rstudio.com/articles/communicating-with-js.html
as.character(actionLink(paste(id, i, sep="_"), label = 'Delete', icon = icon('trash'),
onclick = 'Shiny.setInputValue(\"deletePressed\", this.id, {priority: "event"})'))
}
deleteCol <- unlist(lapply(seq_len(nrow(df)), f))
# Return a data table
DT::datatable(cbind(' ' = deleteCol, df),
# Need to disable escaping for html as string to work
escape = FALSE,
editable = 'cell',
selection = 'single',
rownames = FALSE,
class = 'compact',
options = list(
# Disable sorting for the delete column
dom = 't',
columnDefs = list(list(targets = 1, sortable = FALSE))
))
}
parseDeleteEvent <- function(idstr) {
res <- as.integer(sub(".*_([0-9]+)", "\\1", idstr))
if (! is.na(res)) res
}
# Run the app ----
shinyApp(ui = ui, server = server)
As far as I have looked, there is no ready-to-go solution available. You could try to use rhandsontable. It does not provide all the functionality of the DT table, however it allows for the editing. Last time I tried using it there were some minor issues in some edge cases. (Trying to save different data type or something similar.)
Alternatively you can do the stuff manually, along these lines. This is the minimal working example of editing the underlying data frame. Currently I overwrite it every time the user clicks on the table, you would need to change that to handle normal user behavior. It is meant merely as a proof of concept.
library(DT)
library(shiny)
ui <- fluidPage(
DT::dataTableOutput("test")
)
myDF <- iris[1:10,]
js <- c("table.on('click.dt','tr', function() {",
" var a = table.data();",
" var data = []",
" for (i=0; i!=a.length; i++) {",
" data = data.concat(a[i]) ",
" };",
"Shiny.setInputValue('dataChange', data)",
"})")
server <- function(input, output) {
output$test <- DT::renderDataTable(
myDF,
editable='cell',
callback=JS(js)
)
observeEvent(input$dataChange, {
res <- cbind.data.frame(split(input$dataChange, rep(1:6, times=length(input$dataChange)/6)),
stringsAsFactors=F)
colNumbers <- res[,1]
res <- res[,2:ncol(res)]
colnames(res) <- colnames(myDF)
myDF <<- res
print(myDF)
})
}
shinyApp(ui = ui, server = server)
I am populating a table by using Insert UI elements. I also want to delete both table entries and the inserted panels by using the remove UI elements.
I could delete the panels but as you can see in my demo App the corresponding table values are not deleted and the length of the table remains the same even after clicking the delete button.
How can I delete both the panels and their corresponding table values at the same time?
Why table values are not getting deleted?
library(shiny)
library(tidyverse)
DT <- 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))
ui <- fluidPage( h4("Updating InserUIs",
selectInput("events","Events",choices=as.character(DT$Events)),
tags$div(id = "Panels"),
actionButton("add","Add"),
tableOutput("table"),
verbatimTextOutput("text")
))
server <- function(session, input, output){
# Reactive values for the number of input panels
vals <- reactiveValues(btn = list(), observers = list())
observeEvent(input$add,ignoreNULL = FALSE,{
l <- length(vals$btn) +1
# Add Panels
for(i in l){
vals$btn[[i]]= insertUI(selector = "#Panels",
ui = splitLayout(id = paste0("Selection",i), where ="afterEnd",
cellWidths = rep("33.33%",3),
selectInput(paste0("year",i), "Year", choices = DT$Year,
selected = ""),
numericInput(paste0("area",i), "Area", min = 0, max = 10000,
value ="", step = 1),
numericInput(paste0("money",i), "Money", min = 0, max = 10000,
value = "", step =1),
div(id ="delete_div",actionButton(paste0("delete",i), "Delete"))
))}
# Update panels
for(i in l){
vals$observers = lapply(l, function(i)
observeEvent(input[[paste0("year",i)]],{
updateNumericInput(session,paste0("area",i),
"Area",min= 0, max= 50000,value = DT$Area_Loss
[DT$Year == input[[paste0("year",i)]]& DT$Events==
input$events] ,step = 0.1)
}))}
for(i in l){
vals$observers = lapply(l, function(i)
observeEvent(input[[paste0("year",i)]],{
updateNumericInput(session,paste0("money",i),
"Money",min= 0, max= 50000,value = DT$Money
[DT$Year == input[[paste0("year",i)]]& DT$Events==
input$events] ,step = 0.1)
}))}
# Delete Panels
for(i in l){
observeEvent(input[[paste0("delete",i)]],{
shiny::removeUI(selector = paste0("#Selection",i))
i <- length(vals$btn) - 1
})}
})
# Reactive table generated from the user inputs
Table <- reactive({
l <- 1:length(vals$btn)
for(i in l){
Year <- unlist(lapply(l, function(i)input[[paste0("year",i)]]))
Area <- unlist(lapply(l, function(i)input[[paste0("area",i)]]))
Money <- unlist(lapply(l, function(i)input[[paste0("money",i)]]))
}
DF0 <- data.frame(Event = input$events,
Year = Year,
Area_loss = Area,
Money = Money
)
DF0
})
# Visualizing the raective table
output$table <- renderTable({
Table()
})
}
shinyApp(ui,server)
Thanks all of you in advance, any suggestion will help me to progress in my app.
I think your problem can be quiet elegantly solved with modules. See comments in the code for details.
library(shiny)
library(dplyr)
DT <- 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
## take note about the ns() construct which allows for
## namespacing and through this mechanism we can have several
## instances of this module
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"))
)
}
## in the server you can access the elements simply by input$element_name
## we have one input reactive (event) which comes from the main app and
## holds the value of the event 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) {
killMe <- reactiveVal(FALSE)
observe({
req(input$year)
req(event())
updateNumericInput(session,
"area",
min = 0,
max = 50000,
value = DT$Area_Loss[DT$Year == input$year &
DT$Events == event()] ,
step = 0.1)
updateNumericInput(session,
"money",
min = 0,
max = 50000,
value = DT$Money[DT$Year == input$year &
DT$Events == event()] ,
step = 0.1)
})
get_data <- reactive({
req(!is.null(input$year), !is.null(input$area), !is.null(input$money), event())
data.frame(event = event(),
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))
}
##############################MainApp##############################
ui <- fluidPage(
titlePanel("Modules"),
sidebarLayout(
sidebarPanel(
h4("Updating Inserted UIs"),
selectInput("events",
"Events",
unique(DT$Events)),
actionButton("add",
"Add"),
tableOutput("table")
),
mainPanel(
tags$div(id = "Panels")
)
)
)
## 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
})
observeEvent(input$add, {
id <- paste0("row_", n)
n <<- n + 1
insertUI("#Panels",
"beforeEnd",
YAM_ui(id)
)
new_handler <- setNames(list(callModule(YAM_server,
id,
get_event)),
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)
})
output$table <- renderTable({
hds <- req(handlers())
req(length(hds) > 0)
tbl_list <- lapply(hds, function(h) {
h$get_data()
})
do.call(rbind, tbl_list)
})
}
shinyApp(ui, server)
I agree with #thothal that modules help when adding and removing sections of UI and the corresponding data. I've taken a lot of inspiration from their answer and come up with a slightly cleaner (IMHO) implementation.
I've only modified the final server function, where I have managed to do away with the need to keep a list of observers and have captured most of the lifecycle functionality into the add_module function
# utility to hide away the mess of updating the reactiveVal(list())
update_values <- function(values, name, value) {
vals <- values()
vals[[name]] <- value
values(vals)
}
add_module <- function(values, name, server, delete_hook = NULL, remove_selector = NULL) {
# add module server's return to values list
update_values(values, name, server)
# if module has a reactive we should monitor for deleting, do so
if (!is.null(delete_hook)) {
observeEvent(
server[[delete_hook]](), {
removeUI(selector = remove_selector) # remove the ui
update_values(values, name, NULL) # remove the server from our values list
},
ignoreInit = TRUE,
once = TRUE
)
}
}
server <- function(input, output, session) {
handlers <- reactiveVal(list())
get_event <- reactive({
input$events
})
# new
observeEvent(input$add, {
id <- paste0("row_", input$add)
insertUI("#Panels", "beforeEnd", YAM_ui(id))
add_module(
handlers,
name = id,
server = callModule(YAM_server, id, get_event),
delete_hook = "delete",
remove_selector = paste0("#", id)
)
})
# unchanged
output$table <- renderTable({
hds <- req(handlers())
req(length(hds) > 0)
tbl_list <- lapply(hds, function(h) {
h$get_data()
})
do.call(rbind, tbl_list)
})
}
shinyApp(ui, server)
I am building a relatively complicated app, where I have dynamic number of inputs titled:
d1, d2 .. dn. At one point I wanted to try addressing multiple inputs at the same time with:
input[[grep(pattern="d+[[:digit:]]",input)]]
which of course caused an error:
Must use single string to index into reactivevalues
So I was wondering whether someone knew an elegant way to do such a thing?
You can use names on input :
grep(pattern = "d+[[:digit:]]", x = names(input), value = TRUE)
A working example :
library("shiny")
ui <- fluidPage(
fluidRow(
column(
width = 6,
lapply(
X = 1:6,
FUN = function(i) {
sliderInput(inputId = paste0("d", i), label = i, min = 0, max = 10, value = i)
}
)
),
column(
width = 6,
verbatimTextOutput(outputId = "test")
)
)
)
server <- function(input, output){
output$test <- renderPrint({
sapply(grep(pattern = "d+[[:digit:]]", x = names(input), value = TRUE), function(x) input[[x]])
})
}
shinyApp(ui = ui, server = server)
I'm running into the error "Error in <-: invalid (NULL) left side of assignment" over and over again as I attempt to take a reactive object in Shiny and further manipulate it. I've provided an illustrative example below.
testdf <- data.frame(row1 = c(1,3,6), row2 = c(7, 5, 1))
ui <- fluidPage(
titlePanel("Education in Tanzania"),
sidebarLayout(
sidebarPanel(
#Select aggregation level of data
selectInput("AggregationSelect",
label = "Aggregation",
choices = list("School" = 1,
"District" = 2,
"Region" = 3),
selected = 1)
),
mainPanel(
DT::dataTableOutput("OutputTable")
)
)
)
server <- function(input, output) {
Output1 <- reactive({
testdf
})
observe({
if(2 %in% input$AggregationSelect) {
observe({Output1()$name[3] <- "b"})
} else if(3 %in% input$AggregationSelect) {
observe({Output1()$name[2] <- "c"})
} else if(1 %in% input$AggregationSelect) {
observe({Output1()$name[1] <- "a"})
}
})
output$OutputTable <- {DT::renderDataTable({
DT::datatable(Output1(),
options = list(pagelength = 25,
searching = TRUE,
paging = TRUE,
lengthChange = FALSE),
rownames = FALSE)
})
}
}
shinyApp(ui = ui, server = server)
What I need to do in my actual code is assemble a dataframe through the UI (which I am able to do and therefore have just subbed a random df in here) and then add some information (represented here with the added "names" column) based on what has been selected in the UI. It seems like it shouldn't be all that difficult to add a column to a df, but within the reactive object context, nothing I have attempted has worked. Other ways to modify reactive objects are welcome as long as they can be applied to more complex multi-step scenarios - there's no way I can get everything I need bundled into the initial assignment of the reactive object.
Reactive expressions cannot be modified from outside. You can only modify reactive values.
Generally you should never need to use observe. Use reactive expression if you don't need side effect, use reactive values with observeEvent when needed.
You must read reactive tutorials before going forward. There are quite some concepts need to be understood before you can do anything complex, especially the "force update habit". You need to let Shiny do the update properly and setup the logic correctly.
I suggest you read all the tutorials, articles about reactive in RStudio website, then watch the reactive tutorial video in Shiny conference.
Im not 100% what you're doing but I think its best if you use eventReactive that would listen to your selectInput. Note that I added the variable names to the dataframe:
library(shiny)
testdf <- data.frame(names = c(1,3,6), row2 = c(7, 5, 1))
ui <- fluidPage(
titlePanel("Education in Tanzania"),
sidebarLayout(
sidebarPanel(
#Select aggregation level of data
selectInput("AggregationSelect", label = "Aggregation",
choices = list("School" = 1, "District" = 2, "Region" = 3),selected = 1)
),
mainPanel(
DT::dataTableOutput("OutputTable")
)
)
)
server <- function(input, output) {
Output1 <- eventReactive(input$AggregationSelect,{
if(input$AggregationSelect %in% "2"){
testdf$name[3] <- "b"
return(testdf)
}
else if(input$AggregationSelect %in% "3"){
testdf$name[2] <- "c"
return(testdf)
}
else if(input$AggregationSelect %in% "1"){
testdf$name[1] <- "a"
return(testdf)
}
else{
return(testdf)
}
})
output$OutputTable <- {DT::renderDataTable({
print(Output1())
DT::datatable(Output1(),options = list(pagelength = 25,searching = TRUE,paging = TRUE,lengthChange = FALSE),rownames = FALSE)
})
}
}
shinyApp(ui = ui, server = server)
As per my understanding of your problem, i've tweaked you code as following :
testdf <- data.frame(name = c(1,2,3), freq = c(100, 200, 300))
ui <- fluidPage(
titlePanel("Education in Tanzania"),
sidebarLayout(
sidebarPanel(
#Select aggregation level of data
selectInput("AggregationSelect",
label = "Aggregation",
choices = list("School" = 1,
"District" = 2,
"Region" = 3))
),
mainPanel(
DT::dataTableOutput("OutputTable")
)
))
server <- function(input, output) {
Output1 <- reactive({
input$AggregationSelect
selection <- input$AggregationSelect
if(2 %in% selection){
testdf$name[3] <- "b"
}
else if(3 %in% selection){
testdf$name[2] <- "c"
}
else if(1 %in% selection){
testdf$name[1] <- "a"
}
testdf
})
output$OutputTable <- {DT::renderDataTable({
DT::datatable(Output1(),
options = list(pagelength = 25,
searching = TRUE,
paging = TRUE,
lengthChange = FALSE),
rownames = FALSE)
})
}}
shinyApp(ui = ui, server = server)