I am developing a Shiny app to process temperature data. Sometimes, temperatures loggers are set up in the lab and start measuring before actually being deployed in the field. Therefore, I need to allow the user to crop the data to the actual on-site measurements.
The upload and cropping are both triggered by actionButtons because they require other inputs (time format, delimiter etc.) I have not included in the MWE.
To avoid mixing up datasets, I would like the previous cropped data to be hidden (or better, set to NULL) if a new raw dataset is uploaded.
I tried the following:
ui
library("tidyverse")
library("magrittr")
library("DT")
library("xts")
library("shiny")
library("shinydashboard")
ui <- dashboardPage(
skin = "green",
dashboardHeader(title = "MWE"),
dashboardSidebar(
sidebarMenu(
menuItem("Upload data", tabName = "upload")
)
),
dashboardBody(
tabItems(
tabItem(tabName = "upload",
fluidRow(
box(
title = "Upload settings",
width = 5,
fileInput("fname", "Data", buttonLabel = "Browse..."),
actionButton("uploadbtn", "Upload")
),
box(
title = "Raw data",
width = 7,
DTOutput("raw_table")
)
),
fluidRow(
uiOutput("crop_box"),
box(
width = 8,
h4(strong("Do you wish to crop your data to the selected times?")),
br(),
actionButton("cropbtn", "Crop")
)
),
fluidRow(
box(
title = "Cropped dataset",
width = 12,
DTOutput("cropped_table")
)
)
)
)
)
)
server
server <- function(input, output, session) {
uploaded <- reactiveVal(FALSE)
observeEvent(input$uploadbtn, {
uploaded(TRUE)
})
# Upload raw data
raw <- bindEvent(reactive({
req(input$fname)
# Read in data as zoo object the convert to xts
read.delim.zoo(file = input$fname$datapath,
sep = "\t",
skip = 0,
header = TRUE,
dec = ".",
drop = FALSE,
FUN = as.POSIXct,
tz = "",
format = "%Y.%m.%d %H:%M:%S") %>% as.xts
}),
input$uploadbtn # Only upload once button is clicked
)
# Display raw data
output$raw_table <- renderDT({
req(raw())
datatable(as.data.frame(raw()), options = list(scrollX = TRUE))
})
# Select beginning and end of dataset
first_data <- reactive({
raw() %>% first("1 days") %>% zoo
})
last_data <- reactive({
raw() %>% last("1 days") %>% zoo
})
output$crop_box <- renderUI({
box(
width = 4,
h4(strong("Select the start and end time of on-site measurements.")),
sliderInput("onsite_start", "Start of on-site measurements",
min = as.POSIXct(min(index(first_data()))),
max = as.POSIXct(max(index(first_data()))),
value = min(index(first_data())),
timeFormat = "%F %R"),
sliderInput("onsite_end", "End of on-site measurements",
min = as.POSIXct(min(index(last_data()))),
max = as.POSIXct(max(index(last_data()))),
value = max(index(last_data())))
)
})
cropped <- bindEvent(reactive({
req(raw(), uploaded())
start_indx <- index(raw()) >= as.POSIXct(input$onsite_start) # Get start
end_indx <- index(raw()) <= as.POSIXct(input$onsite_end) # Get end
raw()[which(start_indx & end_indx), , drop = FALSE]
}),
input$cropbtn # Only compute once button is clicked
)
output$cropped_table <- renderDT({
req(cropped())
cropped_data <- isolate(cropped())
uploaded(FALSE)
datatable(as.data.frame(cropped_data))
})
observeEvent(input$uploadbtn, {
updateSliderInput(session = session, "first", value = 1)
updateSliderInput(session = session, "last", value = 1)
updateSliderInput(session = session, "onsite_start", value = as.POSIXct(min(index(first_data()))))
updateSliderInput(session = session, "onsite_end", value = as.POSIXct(max(index(last_data()))))
})
}
shinyApp(ui, server)
My plan was to use uploaded <- reactiveVal(TRUE) as a flag, and to set it to FALSE once the dataset had been cropped, so that it could be set to TRUE again with a new upload. Obviously this doesn't work as the cropped dataset still shows after a new upload.
Note, however, that the updateSliderInputs work as expected when the upload button is clicked, so I gather the error must be in my strategy rather than purely my syntax.
I also tried
observeEvent(input$uploadbtn, {
cropped <<- reactive(NULL)
})
but this obviously just results in nothing being displayed at all, even after clicking input$cropbtn. I struggle to see how to build a condition that fits my needs.
I have looked at Resetting data in R shiny app when file upload fields change, Shiny resetting and updating reactiveValues dataframe with two different buttons, r - How to reset reactiveValues, and shiny - How to invalidate ractive observer using code?. Unfortunately, they did not allow me to find a solution.
Please find sample data here and here (the same data with different dates so you can tell them apart easily).
Try with a reactiveValues object that is set to NULL when a new data file is uploaded.
server <- function(input, output, session) {
croppedd <- reactiveValues(data=NULL)
# uploaded <- reactiveVal(FALSE)
# observeEvent(input$uploadbtn, {
# uploaded(TRUE)
# })
# Upload raw data
raw <- bindEvent(reactive({
req(input$fname)
# Read in data as zoo object the convert to xts
read.delim.zoo(file = input$fname$datapath,
sep = "\t",
skip = 0,
header = TRUE,
dec = ".",
drop = FALSE,
FUN = as.POSIXct,
tz = "",
format = "%Y.%m.%d %H:%M:%S") %>% as.xts
}),
input$uploadbtn # Only upload once button is clicked
)
# Display raw data
output$raw_table <- renderDT({
req(raw())
datatable(as.data.frame(raw()), options = list(scrollX = TRUE))
})
# Select beginning and end of dataset
first_data <- reactive({
raw() %>% first("1 days") %>% zoo
})
last_data <- reactive({
raw() %>% last("1 days") %>% zoo
})
output$crop_box <- renderUI({
box(
width = 4,
h4(strong("Select the start and end time of on-site measurements.")),
sliderInput("onsite_start", "Start of on-site measurements",
min = as.POSIXct(min(index(first_data()))),
max = as.POSIXct(max(index(first_data()))),
value = min(index(first_data())),
timeFormat = "%F %R"),
sliderInput("onsite_end", "End of on-site measurements",
min = as.POSIXct(min(index(last_data()))),
max = as.POSIXct(max(index(last_data()))),
value = max(index(last_data())))
)
})
cropped <- bindEvent(reactive({
req(raw(), uploaded())
start_indx <- index(raw()) >= as.POSIXct(input$onsite_start) # Get start
end_indx <- index(raw()) <= as.POSIXct(input$onsite_end) # Get end
raw()[which(start_indx & end_indx), , drop = FALSE]
}),
input$cropbtn # Only compute once button is clicked
)
observe({
croppedd$data <- cropped()
})
output$cropped_table <- renderDT({
req(cropped())
# cropped_data <- isolate(cropped())
# uploaded(FALSE)
datatable(as.data.frame(croppedd$data))
})
observeEvent(input$uploadbtn, {
croppedd$data <- NULL
# updateSliderInput(session = session, "first", value = 1)
# updateSliderInput(session = session, "last", value = 1)
updateSliderInput(session = session, "onsite_start", value = as.POSIXct(min(index(first_data()))))
updateSliderInput(session = session, "onsite_end", value = as.POSIXct(max(index(last_data()))))
})
}
Related
I tried to keep reprex as simple as possible.
I want to save with the ADD button currently chosen inputs, inside Data Frame (selected by index passed by userId input), which is inside the list, and later on use this Data Frame to render a table (in the final app make a plot).
Here I figured out, how to save values inside the data frame. (not data frame inside a list)
How to save input to data frame, and use it later in Shiny?
Now Add button returns this:
Warning: Error in choosen_user: unused argument (rbind(choosen_user(), new_day_rate())) <- this is propably because I used reactive() not reactiveVal(), but with reactiveVal() there is this error:
Warning: Error in .getReactiveEnvironment()$currentContext: Operation not allowed without an active reactive context.
You tried to do something that can only be done from inside a reactive consumer.
library(shiny)
# Saved_users_list normally came from external file
saved_users_list <- list(data.frame(date = c(as.Date("2022-04-18"),
as.Date("2022-04-19")),
rate = c(8,1),
day_comment = c("Found a gf",
"Broke my arm")),
data.frame(date = c(as.Date("2022-04-18"),
as.Date("2022-04-19")),
rate = c(10,1),
day_comment = c("Found a job",
"They fired me")))
ui <- fluidPage(
sidebarLayout(
sidebarPanel(
selectInput("userId", "userId", choices = c(1:2)),
sliderInput("day_rate", "Rate your day", min = 0, max = 10, value = 5, step = 0.5),
dateInput("date", "Pick a date"),
textAreaInput("comment", "Comment", placeholder = "Add a description (OPTIONAL)"),
actionButton("add", "Add"),
actionButton("test", "Test values") # Button to test inputs values
),
mainPanel(
tableOutput("test_table")
)
)
)
server <- function(input, output, session) {
users_list <- reactiveVal(saved_users_list)
selected_user <- reactive(as.numeric(input$userId))
output$test_table <- renderTable({
users_list()[selected_user()]
})
new_day_rate <- reactive(list(data.frame(date = input$date,
rate = input$day_rate,
day_comment = input$comment)))
choosen_user <- reactive(users_list()[[selected_user()]])
# Button to add values to the data frame inside users_list
observeEvent(input$add, {
# users_list()[[selected_user()]] <- rbind(users_list()[[selected_user()]], as.data.frame(new_day_rate())) # Error in <-: invalid (NULL) left side of assignment
choosen_user(rbind(choosen_user(), new_day_rate())) # Here I tried to implement a solution from linked question
})
# Button to test inputs values
observeEvent(input$test, {
message("userId: ", input$userId, " ", class(input$userId))
message("selected_user(): ", selected_user())
message("new_day_rate(): ", new_day_rate())
message("str(new_day_rate()): ", str(new_day_rate()))
message("users_list()[[selected_user()]]: ",users_list()[[selected_user()]])
})
}
shinyApp(ui, server)
I think you're after reactiveValues? Something like:
library(shiny)
# Saved_users_list normally came from external file
saved_users_list <- list(
data.frame(
date = c(as.Date("2022-04-18"), as.Date("2022-04-19")),
rate = c(8,1),
day_comment = c("Found a gf", "Broke my arm")
),
data.frame(
date = c(as.Date("2022-04-18"), as.Date("2022-04-19")),
rate = c(10,1),
day_comment = c("Found a job", "They fired me")
)
)
ui <- fluidPage(
sidebarLayout(
sidebarPanel(
selectInput("userId", "userId", choices = c(1:2)),
sliderInput("day_rate", "Rate your day", min = 0, max = 10, value = 5, step = 0.5),
dateInput("date", "Pick a date"),
textAreaInput("comment", "Comment", placeholder = "Add a description (OPTIONAL)"),
actionButton("add", "Add"),
actionButton("test", "Test values") # Button to test inputs values
),
mainPanel(
tableOutput("test_table")
)
)
)
server <- function(input, output, session) {
cache <- reactiveValues(saved_users = saved_users_list)
selected_user <- reactive(as.numeric(input$userId))
output$test_table <- renderTable({
cache$saved_users[selected_user()]
})
new_day_rate <- reactive(
data.frame(
date = as.Date(input$date),
rate = input$day_rate,
day_comment = input$comment
)
)
observeEvent(input$add, {
cache$saved_users[[selected_user()]] <- rbind(
cache$saved_users[[selected_user()]], new_day_rate()
)
})
observeEvent(input$test, {
message("userId: ", input$userId, " ", class(input$userId))
message("selected_user(): ", selected_user())
message("new_day_rate(): ", new_day_rate())
message("str(new_day_rate()): ", str(new_day_rate()))
message("users_list()[[selected_user()]]: ", cache$saved_users[[selected_user()]])
})
}
shinyApp(ui, server)
I am currently building a budgeting shiny application that prompts users to enter information of their past transactions such as: Amount, Type, and Description. I would like to have this information displayed in a Kable styled table in a seperate tab whenever a user hits submit, however, when I do this I get the following message and the table does not display:
"Warning: Error in as.data.frame.default: cannot coerce class ‘c("kableExtra", "knitr_kable")’ to a data.frame"
Here is what I have coded so far:
# Libraries
library(shiny)
library(ggplot2)
library(shinythemes)
library(DT)
library(kableExtra)
ui <- fluidPage(
theme = shinytheme("spacelab"),
## Application Title
titlePanel("2021 Budgeting & Finances"),
tags$em("By:"),
tags$hr(),
navbarPage("", id = "Budget",
tabPanel("Data Entry",
div(class = "outer",
# Sidebar Layout
sidebarLayout(
sidebarPanel(
selectInput("Name",
label = "Name:",
choices = c("","Jack", "Jill")),
selectInput("Bucket",
label = "Item Bucket:",
choices = c("","Essential", "Non-Essential", "Savings", "Rent/Bills", "Trip", "Other")),
textInput("Item",
label = "Item Name:",
placeholder = "Ex: McDonald's"),
shinyWidgets::numericInputIcon("Amount",
"Amount:",
value = 0,
step = 0.01,
min = 0,
max = 1000000,
icon = list(icon("dollar"), NULL)),
dateInput("Date",
label = "Date",
value = Sys.Date(),
min = "2021-05-01",
max = "2022-12-31",
format = "M-d-yyyy"),
actionButton("Submit", "Submit", class = "btn btn-primary"),
downloadButton("Download", "Download")),
# Show a plot of the generated distribution
mainPanel(
dataTableOutput("PreviewTable")
)
)
)
),
tabPanel("Monthly Budget",
tableOutput("MonthlyTable")
),
tabPanel("Budget to Date",
tableOutput("YearTable")
)
)
)
server <- function(input, output, session) {
## SAVE DATA
# Set Up Empty DF
df <- tibble("Name" = character(),
"Date" = character(),
"Category" = character(),
"Amount" = numeric(),
"Description" = character())
# DF is made reactive so we can add new lines
ReactiveDf <- reactiveVal(value = df)
# Add inputs as new data (lines)
observeEvent(input$Submit, {
if (input$Bucket == "" | input$Amount == 0 |
is.na(input$Amount)) {
return(NULL)
}
else {
# New lines are packaged together in a DF
new_lines <- data.frame(Name = as.character(input$Name),
Date = as.character(input$Date),
Category = input$Bucket,
Amount = as.character(input$Amount),
Description = as.character(input$Item))
# change df globally
df <<- rbind(df, new_lines)
# ensure amount is numeric
df <<- df %>%
mutate("Amount" = as.numeric(Amount))
# Update reactive values
ReactiveDf(df)
#clear out original inputs now that they are written to df
updateSelectInput(session, inputId = "Name", selected = "")
updateSelectInput(session, inputId = "Bucket", selected = "")
updateNumericInput(session, inputId = "Amount", value = 0)
updateTextInput(session, inputId = "Item", value = "")
}
})
## Preview Table
output$PreviewTable <- renderTable({
ReactiveDf()
})
## MONTHLY TABLE
output$MonthlyTable <- renderTable({
ReactiveDf() %>%
kbl()
})
## YEAR TO DATE TABLE
output$YearTable <- renderTable({
ReactiveDf()
})
}
# Run the application
shinyApp(ui = ui, server = server)
Ideally what I would like to have is a table preview on the main page where the user enters their information that updates once the user submits their data. Then, I would like the month tab to populate with only the data relating to the current month and the year tab to have all information for the current year. However the biggest issue currently is that the kable table is not displaying. Any help is greatly appreciated!
Kable is plain Html so it doesn't require special render functions. This should work.
## MONTHLY TABLE
output$MonthlyTable <- function(){
ReactiveDf() %>%
kable("html") %>%
kable_styling("striped", full_width = TRUE)
}
Am trying to build a simple Shiny app to calculate air quality index. Following is the code chunk for Shiny ui -
ui <- fluidPage(theme = shinytheme("slate"),
# Page header
headerPanel('Air Quality Index'),
# Input values
sidebarPanel(
HTML("<h3>Input Air Parameters</h3>"),
selectInput("City", label = "Please Select the City:",
choices = list("abc", "def" , "xyz"),
selected = "abc"),
sliderInput("PM2.5", "PM2.5 Levels:",
min = 0, max = 1000,
value = 50),
sliderInput("PM10", "PM10 Levels:",
min = 0, max = 1000,
value = 90),
actionButton("submitbutton", "Calculate AQI", class = "btn btn-primary")
),
mainPanel(
tags$label(h3('Air Quality Index-')), # Status/Output Text Box
verbatimTextOutput('contents'),
tableOutput('tabledata') # Prediction results table
)
)
And the server code is -
server <- function(input, output, session) {
# Input Data
datasetInput <- reactive({
df1 <- data.frame(
Names= c("City",
"PM2.5",
"PM10"),
Values = as.character(c(input$City,
input$PM2.5,
input$PM10)),
stringsAsFactors = FALSE)
AQI <- "AQI"
df1 <- rbind(df1, AQI)
input <- data.table::transpose(df1)
write.table(input,"input.csv", sep=",", quote = FALSE, row.names = FALSE, col.names = FALSE)
test <- read.csv(paste("input", ".csv", sep=""), header = TRUE)
Output <- data.frame(Prediction=predict(RandomForest_AQI_Model,test))
print(Output)
})
# Status/Output Text Box
output$contents <- renderPrint({
if (input$submitbutton>0) {
isolate("Calculation complete.")
} else {
return("Server is ready for calculation.")
}
})
# Prediction results table
output$tabledata <- renderTable({
if (input$submitbutton>0) {
isolate(datasetInput())
}
})
}
And here is the problem occurs, after running the app in RStudio the UI loads correctly. But, when I submit my inputs to perform calculation, it throws the error for differing row numbers.
I don't know what's going wrong in data.frame function in server
I am uploading question for the first time so if I made any mistake in posting please let me know.
Any help would be awesome
Thanks!
UPDATED: An example of the problem is shown below the code for the app
I'm building an dynamic ML app where the user can upload a dataset to get a prediction of the first column in the dataset (the response variable should be located in column 1 of the uploaded dataset). The user can select a value for the variables in the uploaded dataset and get a prediction of the response variable.
I'm currently trying to create a datatable that stores all the selected values, timestamp and the prediction.
The table is suppose to store the previous saved values, but only for that perticular dataset. By this I mean that if I save values from the iris dataset, the table uses the variables from the iris dataset as columns. This causes problems when uploading another dataset and saving those values, since the columns from the iris dataset would still be there and not the variables/columns from the new dataset.
My question is: How do I create a unique datatable for each dataset uploaded to the app?
If this sound confusion, try to run the app, calculate a prediction and save the data. Do this for two different datasets and look at the datatable under the "log" tab.
If you don't have two datasets, you can use these two datasets, they are build into R as default and already have the response variable positioned in column 1.
write_csv(attitude, "attitude.csv")
write_csv(ToothGrowth, "ToothGrowth.csv")
You will find the code regarding the datatable under the 'Create the log' section in the server function.
This is the code for the app:
library(shiny)
library(tidyverse)
library(shinythemes)
library(data.table)
library(RCurl)
library(randomForest)
library(mlbench)
library(janitor)
library(caret)
library(recipes)
library(rsconnect)
# UI -------------------------------------------------------------------------
ui <- fluidPage(
navbarPage(title = "Dynamic ML Application",
tabPanel("Calculator",
sidebarPanel(
h3("Values Selected"),
br(),
tableOutput('show_inputs'),
hr(),
actionButton("submitbutton", label = "calculate", class = "btn btn-primary", icon("calculator")),
actionButton("savebutton", label = "Save", icon("save")),
hr(),
tableOutput("tabledata")
), # End sidebarPanel
mainPanel(
h3("Variables"),
uiOutput("select")
) # End mainPanel
), # End tabPanel Calculator
tabPanel("Log",
br(),
DT::dataTableOutput("datatable18", width = 300),
), # End tabPanel "Log"
tabPanel("Upload file",
br(),
sidebarPanel(
fileInput(inputId = "file1", label="Upload file"),
checkboxInput(inputId ="header", label="header", value = TRUE),
checkboxInput(inputId ="stringAsFactors", label="stringAsFactors", value = TRUE),
radioButtons(inputId = "sep", label = "Seperator", choices = c(Comma=",",Semicolon=";",Tab="\t",Space=" "), selected = ","),
radioButtons(inputId = "disp", "Display", choices = c(Head = "head", All = "all"), selected = "head"),
), # End sidebarPanel
mainPanel(
tableOutput("contents")
)# End mainPanel
) # EndtabPanel "upload file"
) # End tabsetPanel
) # End UI bracket
# Server -------------------------------------------------------------------------
server <- function(input, output, session) {
# Upload file content table
get_file_or_default <- reactive({
if (is.null(input$file1)) {
paste("No file is uploaded yet")
} else {
df <- read.csv(input$file1$datapath,
header = input$header,
sep = input$sep,
quote = input$quote)
if(input$disp == "head") {
return(head(df))
}
else {
return(df)
}
}
})
output$contents <- renderTable(get_file_or_default())
# Create input widgets from dataset
output$select <- renderUI({
req(input$file1)
if (is.null(input$file1)) {
"No dataset is uploaded yet"
} else {
df <- read.csv(input$file1$datapath,
header = input$header,
sep = input$sep,
quote = input$quote)
tagList(map(
names(df[-1]),
~ ifelse(is.numeric(df[[.]]),
yes = tagList(sliderInput(
inputId = paste0(.),
label = .,
value = mean(df[[.]], na.rm = TRUE),
min = round(min(df[[.]], na.rm = TRUE),2),
max = round(max(df[[.]], na.rm = TRUE),2)
)),
no = tagList(selectInput(
inputId = paste0(.),
label = .,
choices = sort(unique(df[[.]])),
selected = sort(unique(df[[.]]))[1],
))
) # End ifelse
)) # End tagList
}
})
# creating dataframe of selected values to be displayed
AllInputs <- reactive({
req(input$file1)
if (is.null(input$file1)) {
} else {
DATA <- read.csv(input$file1$datapath,
header = input$header,
sep = input$sep,
quote = input$quote)
}
id_exclude <- c("savebutton","submitbutton","file1","header","stringAsFactors","input_file","sep","contents","head","disp")
id_include <- setdiff(names(input), id_exclude)
if (length(id_include) > 0) {
myvalues <- NULL
for(i in id_include) {
if(!is.null(input[[i]]) & length(input[[i]] == 1)){
myvalues <- as.data.frame(rbind(myvalues, cbind(i, input[[i]])))
}
}
names(myvalues) <- c("Variable", "Selected Value")
myvalues %>%
slice(match(names(DATA[,-1]), Variable))
}
})
# render table of selected values to be displayed
output$show_inputs <- renderTable({
if (is.null(input$file1)) {
paste("No dataset is uploaded yet.")
} else {
AllInputs()
}
})
# Creating a dataframe for calculating a prediction
datasetInput <- reactive({
req(input$file1)
DATA <- read.csv(input$file1$datapath,
header = input$header,
sep = input$sep,
quote = input$quote)
DATA <- as.data.frame(unclass(DATA), stringsAsFactors = TRUE)
response <- names(DATA[1])
model <- randomForest(eval(parse(text = paste(names(DATA)[1], "~ ."))),
data = DATA, ntree = 500, mtry = 3, importance = TRUE)
df1 <- data.frame(AllInputs(), stringsAsFactors = FALSE)
input <- transpose(rbind(df1, names(DATA[1])))
write.table(input,"input.csv", sep=",", quote = FALSE, row.names = FALSE, col.names = FALSE)
test <- read.csv(paste("input.csv", sep=""), header = TRUE)
# Defining factor levels for factor variables
cnames <- colnames(DATA[sapply(DATA,class)=="factor"])
if (length(cnames)>0){
lapply(cnames, function(par) {
test[par] <<- factor(test[par], levels = unique(DATA[,par]))
})
}
# Making the actual prediction and store it in a data.frame
Prediction <- predict(model,test)
Output <- data.frame("Prediction"=Prediction)
print(format(Output, nsmall=2, big.mark=","))
})
# display the prediction when the submit button is pressed
output$tabledata <- renderTable({
if (input$submitbutton>0) {
isolate(datasetInput())
}
})
# -------------------------------------------------------------------------
# Create the Log
saveData <- function(data) {
data <- as.data.frame(t(data))
if (exists("datatable18")) {
datatable18 <<- rbind(datatable18, data)
} else {
datatable18 <<- data
}
}
loadData <- function() {
if (exists("datatable18")) {
datatable18
}
}
# Whenever a field is filled, aggregate all form data
formData <- reactive({
DATA <- read.csv(input$file1$datapath,
header = input$header,
sep = input$sep,
quote = input$quote)
fields <- c(colnames(DATA[,-1]), "Timestamp", "Prediction")
data <- sapply(fields, function(x) input[[x]])
data$Timestamp <- as.character(Sys.time())
data$Prediction <- as.character(datasetInput())
data
})
# When the Submit button is clicked, save the form data
observeEvent(input$savebutton, {
saveData(formData())
})
# Show the previous responses
# (update with current response when Submit is clicked)
output$datatable18 <- DT::renderDataTable({
input$savebutton
loadData()
})
} # End server bracket
# ShinyApp -------------------------------------------------------------------------
shinyApp(ui, server)
UPDATED HERE
To get an idea about how the problem occurs take a look at this:
I upload the iris dataset to the application.
I then make some predictions and save them.
The predictions, as well as the selected inputs and a timestamp of when the save-button was pressed can now be seen under the "Log" tab.
I upload a new dataset (attitude), which of course have different variables included (attitude dataset has 7 variables total, iris dataset has 5).
I calculate a prediction, hit the save button and the app crashes. This happens because the number of columns in the dataset now has changed, so I get this errormessage:
Error in rbind: numbers of columns of arguments do not match
This can be fixed by renaming the datatable object in the server, since this creates a new datatable without any specified columns yet. But as soon as the Save button is pressed for the first time, the datatable locks-in the columns so they can't be changed again.
I can still access the old datatables if I switch the name of the datatable in the server function back the original name. So I'm thinking that if the name of the datatable object can be dynamic dependend on the dataset uploaded to the app, then the correct datatable can be shown.
So I think a better question could be: How do I create a dynamic/reactive datatable output object
Here's a simple shiny app that demonstrates a technique of storing a list of data (and properties). I'll store it in alldata (a reactive-value), and each dataset has the following properties:
name, just the name, redundant with the name of the list itself
depvar, stored dependent-variable, allowing the user to select which of the variables is used; in the displayed table, this is shown as the first column, though the original data is in its original column-order
data, the raw data (data.frame)
created and modified, timestamps; you said timestamps, but I didn't know if you meant on a particular dataset/prediction/model or something else, so I did this instead
Note that the same data can be uploaded multiple times: while I don't know if this is needed, it is allowed since all referencing is done on the integer index within the alldata list, not the names therein.
library(shiny)
NA_POSIXt_ <- Sys.time()[NA] # for class-correct NA
defdata <- list(
mtcars = list(
name = "mtcars",
depvar = "mpg",
data = head(mtcars, 10),
created = Sys.time(),
modified = NA_POSIXt_
),
CO2 = list(
name = "CO2",
depvar = "uptake",
data = head(CO2, 20),
created = Sys.time(),
modified = NA_POSIXt_
)
)
makelabels <- function(x) {
out <- mapply(function(ind, y) {
cre <- format(y$created, "%H:%M:%S")
mod <- format(y$modified, "%H:%M:%S")
if (is.na(mod)) mod <- "never"
sprintf("[%d] %s (cre: %s ; mod: %s)", ind, y$name, cre, mod)
}, seq_along(x), x)
setNames(seq_along(out), out)
}
ui <- fluidPage(
sidebarLayout(
sidebarPanel(
selectInput("seldata", label = "Selected dataset", choices = makelabels(defdata)),
selectInput("depvar", label = "Dependent variable", choices = names(defdata[[1]]$data)),
hr(),
fileInput("file1", label = "Upload data"),
textInput("filename1", label = "Data name", placeholder = "Derive from filename"),
checkboxInput("header", label = "Header", value = TRUE),
checkboxInput("stringsAsFactors", label = "stringsAsFactors", value = TRUE),
radioButtons("sep", label = "Separator",
choices = c(Comma = ",", Semicolon = ";", Tab = "\t", Space = " "),
select = ","),
radioButtons("quote", label = "Quote",
choices = c(None = "", "Double quote" = '"', "Single quote" = "'"),
selected = '"')
),
mainPanel(
tableOutput("contents")
)
)
)
server <- function(input, output, session) {
alldata <- reactiveVal(defdata)
observeEvent(input$seldata, {
dat <- alldata()[[ as.integer(input$seldata) ]]
choices <- names(dat$data)
selected <-
if (!is.null(dat$depvar) && dat$depvar %in% names(dat$data)) {
dat$depvar
} else names(dat$data)[1]
updateSelectInput(session, "depvar", choices = choices, selected = selected)
# ...
# other things you might want to update when the user changes dataset
})
observeEvent(input$depvar, {
ind <- as.integer(input$seldata)
alldat <- alldata()
if (alldat[[ ind ]]$depvar != input$depvar) {
# only update alldata() when depvar changes
alldat[[ ind ]]$depvar <- input$depvar
alldat[[ ind ]]$modified <- Sys.time()
lbls <- makelabels(alldat)
sel <- as.integer(input$seldata)
updateSelectInput(session, "seldata", choices = lbls, selected = lbls[sel])
alldata(alldat)
}
})
observeEvent(input$file1, {
req(input$file1)
df <- tryCatch({
read.csv(input$file1$datapath,
header = input$header, sep = input$sep,
stringsAsFactors = input$stringsAsFactors,
quote = input$quote)
}, error = function(e) e)
if (!inherits(df, "error")) {
if (!NROW(df) > 0 || !NCOL(df) > 0) {
df <- structure(list(message = "No data found"), class = c("simpleError", "error", "condition"))
}
}
if (inherits(df, "error")) {
showModal(modalDialog(title = "Error loading data", "No data was found in the file"))
} else {
nm <-
if (nzchar(input$filename1)) {
input$filename1
} else tools:::file_path_sans_ext(basename(input$file1$name))
depvar <- names(df)[1]
newdat <- setNames(list(list(name = nm, depvar = depvar, data = df,
created = Sys.time(), modified = NA_POSIXt_)),
nm)
alldat <- alldata()
alldata( c(alldat, newdat) )
# update the selectInput to add this new dataset
lbls <- makelabels(alldata())
sel <- length(lbls)
updateSelectInput(session, "seldata", choices = lbls, selected = lbls[sel])
}
})
output$contents <- renderTable({
req(input$seldata)
seldata <- alldata()[[ as.integer(input$seldata) ]]
# character
depvar <- seldata$depvar
othervars <- setdiff(names(seldata$data), seldata$depvar)
cbind(seldata$data[, depvar, drop = FALSE], seldata$data[, othervars, drop = FALSE])
})
}
shinyApp(ui, server)
There is no ML, no modeling, nothing else in this shiny app, it just shows one possible method for switching between multiple datasets.
For your functionality, you'll need to react to input$seldata to find when the user changes dataset. Note that (1) I'm returning the integer of the list index, and (2) selectInput always returns a string. From this, if the user selects the second dataset in the pull-down, you will get "2", which will obviously not index by itself. Your data must be referenced as alldata()[[ as.integer(input$seldata) ]].
To support repeated-data with less ambiguity, I added the timestamps to the selectInput text, so you can see the "when" of some data. Perhaps overkill, easily removed.
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)