Related
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()))))
})
}
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)
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 have created an App that will use an randomforest model to predict the type of Species in the Iris dataset. The idea is that a user can select a value for the other varaibles using input widgets, which the model then use to give a prediction. This all works fine.
I recently decided to implement a log containing the different inputs, a timestamp and the estimation. I've placed this log in another tabPanel to give a better overview. Everything apperes to work fine, when I hit the save button, the inputs, timestamp and estimation are saved in the log, however, when I go back to the original tabPanel ("Calculator"), errors appear saying that the number of columns doesn't match (or something like that, I have translated it from danish).
Does anyone know why this problem occours and how to fix it?
Im also having trouble running the app by using the "Run App" button in R. It works fine when I select everything with ctrl+A and hit ctrl+enter to run the code.
Here is my code:
require(shiny)
require(tidyverse)
require(shinythemes)
require(data.table)
require(RCurl)
require(randomForest)
require(mlbench)
require(janitor)
require(caret)
require(recipes)
require(rsconnect)
# Read data
DATA <- datasets::iris
# Rearrange data so the response variable is located in column 1
DATA <- DATA[,c(names(DATA)[5],names(DATA)[-5])]
# Creating a model
model <- randomForest(DATA$Species ~ ., data = DATA, ntree = 500, mtry = 3, importance = TRUE)
.# UI -------------------------------------------------------------------------
ui <- fluidPage(
navbarPage(title = "Dynamic Calculator",
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("datatable15", width = 300),
) # End tabPanel "Log"
) # End tabsetPanel
) # End UI bracket
# Server -------------------------------------------------------------------------
server <- function(input, output, session) {
# Create input widgets from dataset
output$select <- renderUI({
df <- req(DATA)
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({
id_exclude <- c("savebutton","submitbutton")
id_include <- setdiff(names(input), id_exclude)
if (length(id_include) > 0) {
myvalues <- NULL
for(i in id_include) {
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({
AllInputs()
})
# Creating a dataframe for calculating a prediction
datasetInput <- reactive({
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("datatable15")) {
datatable15 <<- rbind(datatable15, data)
} else {
datatable15 <<- data
}
}
loadData <- function() {
if (exists("datatable15")) {
datatable15
}
}
# Whenever a field is filled, aggregate all form data
formData <- reactive({
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$datatable15 <- DT::renderDataTable({
input$savebutton
loadData()
})
} # End server bracket
# ShinyApp -------------------------------------------------------------------------
shinyApp(ui, server)
When creating your reactive AllInputs, you are making a loop on id_include.
The problem is that all input[[i]] are not length 1 : they can be NULL or length more than one.
You cannot use a cbind on two variables of different lengths, which causes the mistake.
So I added a condition before calculating myvalues, and everything works fine :
# creating dataframe of selected values to be displayed
AllInputs <- reactive({
id_exclude <- c("savebutton","submitbutton")
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))
}
})
By the way, for loops are not good practice in R, you may want to have a look at apply family functions.
I am trying to build an app that displays a .csv file in table format. The user can choose with radio buttons one of two ways to display the table. I have defined those two ways with the filedata() and data_ranked_words() reactives.
To reproduce this error, please first run this code chunk to get a small subset of my data:
test = rbind(
c(0.00000009, 0.00000009, 0.00046605, 0.00015541, 0.00215630),
c(0.00000016, 0.00137076, 0.00000016, 0.00000016, 0.00000016),
c(0.00012633, 0.00000014, 0.00000014, 0.00000014, 0.00075729),
c(0.00000013, 0.00000013, 0.00000013, 0.00000013, 0.00062728)
)
colnames(test) = c('church', 'appearance', 'restrain', 'parity', 'favor')
rownames(test) = NULL
test = as.data.frame(test)
write.csv(test, 'test.csv', row.names = FALSE)
You will see that you get an Error invalid argument to binary operator as soon as the program launches. Then choose test.csv off your filesystem in your working directory and you will see that the error persists while 'Word View' is selected, but the table correctly displays while 'Probability View' is selected.
This app is very simple. The problem occurs in line 66 temp = matrix(row.names(data)[apply(-data, 2, order)], nrow(data)). It doesn't like the -data within the apply. However, try as I might, I have not been able to reproduce this error just working in the R console, outside of shiny. In regular R, this line runs just fine.
What I am trying to do is display two different tables when the user selects the radio buttons. 'Probability View' is the raw table as is, and 'Word View' is the table with some operations on it (lines 61-71). I can't figure this one out!
Here is my app:
library(shiny)
library(markdown)
library(DT)
library(D3TableFilter)
options(shiny.maxRequestSize=50*1024^2)
# ui.R
#-------------------------------------------------------------------------------------
ui <- shinyUI(
navbarPage("Topic Model App v1.0",
tabPanel("From CSV",
sidebarLayout(
sidebarPanel(
# Define what's in the sidebar
fileInput("file",
"Choose CSV files from directory",
multiple = TRUE,
accept=c('text/csv',
'text/comma-separated-values,text/plain',
'.csv')),
radioButtons('toggle', 'Choose one:',
list('Word View', 'Probability View'))
),
# Define what's in the main panel
mainPanel(
title = 'Topic Model Viewer',
# How wide the main table will be
fluidRow(
column(width = 12, d3tfOutput('data'))
)
)
)
)
)
)
# server.R
#-------------------------------------------------------------------------------------
server <- shinyServer(function(input, output, session) {
# Set up the dataframe for display in the table
# Define 'filedata()' as the .csv file that is uploaded
filedata <- reactive({
infile <- input$file
if (is.null(infile)) {
# User has not uploaded a file yet
return(NULL)
}
# Read in .csv file and clean up
data = read.csv(infile$datapath)
data = t(data)
data = as.data.frame(data)
colnames(data) = paste0(rep('topic', ncol(data)), 1:ncol(data))
data = format(data, scientific = FALSE)
data
})
#PROBLEM
# The ranked and ordered csv file
data_ranked_words <- reactive({
# Sort each column by probability, and substitute the correct word into that column
# This will essentially rank each word for each topic
# This is done by indexing the row names by the order of each column
data = filedata()
temp = matrix(row.names(data)[apply(-data, 2, order)], nrow(data))
temp = as.data.frame(temp)
colnames(temp) = paste0(rep('topic', ncol(data)), 1:ncol(data))
temp
})
# Create table
output$data <- renderD3tf({
tableProps <- list(
rows_counter = TRUE,
rows_counter_text = "Rows: ",
alternate_rows = TRUE
);
# Radio buttons
# The reason why the extensions are in this if() is so that sorting can be
# activated on Probability View, but not Word View
if(input$toggle=='Word View'){
df = data_ranked_words()
extensions <- list(
list( name = "colsVisibility",
text = 'Hide columns: ',
enable_tick_all = TRUE
),
list( name = "filtersVisibility",
visible_at_start = FALSE)
)
} else if(input$toggle=='Probability View'){
df = filedata()
extensions <- list(
list(name = "sort"), #this enables/disables sorting
list( name = "colsVisibility",
text = 'Hide columns: ',
enable_tick_all = TRUE
),
list( name = "filtersVisibility",
visible_at_start = FALSE)
)
}
if(is.null(filedata())){
} else{
d3tf(df,
tableProps = tableProps,
extensions = extensions,
showRowNames = TRUE,
tableStyle = "table table-bordered")
}
})
# This line will end the R session when the Shiny app is closed
session$onSessionEnded(stopApp)
})
# Run app in browser
runApp(list(ui=ui,server=server), launch.browser = TRUE)
So a couple of problems are interacting here to make things difficult to diagnose:
It is running through and trying to execute before the data is defined. The "modern" way to avoid that is to use a req(input$file) - which is now inserted in the filedata reactive. Note that will break the entire chain from executing until input$file is defined in the shiny ui.
The data = format(data, scientific = FALSE) is converting your columns to vectors of type "AsIs", which the unitary minus command does not know how to operate on. It is commented out of filedata() now.
To get that functionality of suppressing the scientific notation back, the was moved to right after where df is created by filedata() before it is displayed in d3tf.
Note: I found it interesting that options with scipen did not work here. Not sure why that is the case, but this AsIs class does the trick.
Here is the adjusted code:
library(shiny)
library(markdown)
library(DT)
library(D3TableFilter)
options(shiny.maxRequestSize=50*1024^2)
# ui.R
#-------------------------------------------------------------------------------------
ui <- shinyUI(
navbarPage("Topic Model App v1.0",
tabPanel("From CSV",
sidebarLayout(
sidebarPanel(
# Define what's in the sidebar
fileInput("file",
"Choose CSV files from directory",
multiple = TRUE,
accept=c('text/csv',
'text/comma-separated-values,text/plain',
'.csv')),
radioButtons('toggle', 'Choose one:',
list('Word View', 'Probability View'))
),
# Define what's in the main panel
mainPanel(
title = 'Topic Model Viewer',
# How wide the main table will be
fluidRow(
column(width = 12, d3tfOutput('data'))
)
)
)
)
)
)
# server.R
#-------------------------------------------------------------------------------------
server <- shinyServer(function(input, output, session) {
# Set up the dataframe for display in the table
# Define 'filedata()' as the .csv file that is uploaded
filedata <- reactive({
req(input$file)
infile <- input$file
if (is.null(infile)) {
# User has not uploaded a file yet
return(NULL)
}
# Read in .csv file and clean up
data = read.csv(infile$datapath)
data = t(data)
data = as.data.frame(data)
colnames(data) = paste0(rep('topic', ncol(data)), 1:ncol(data))
# data = format(data, scientific = FALSE)
data
})
#PROBLEM
# The ranked and ordered csv file
data_ranked_words <- reactive({
# Sort each column by probability, and substitute the correct word into that column
# This will essentially rank each word for each topic
# This is done by indexing the row names by the order of each column
data = filedata()
temp = matrix(row.names(data)[apply(-data, 2, order)], nrow(data))
temp = as.data.frame(temp)
colnames(temp) = paste0(rep('topic', ncol(data)), 1:ncol(data))
temp
})
# Create table
output$data <- renderD3tf({
tableProps <- list(
rows_counter = TRUE,
rows_counter_text = "Rows: ",
alternate_rows = TRUE
);
# Radio buttons
# The reason why the extensions are in this if() is so that sorting can be
# activated on Probability View, but not Word View
if(input$toggle=='Word View'){
df = data_ranked_words()
extensions <- list(
list( name = "colsVisibility",
text = 'Hide columns: ',
enable_tick_all = TRUE
),
list( name = "filtersVisibility",
visible_at_start = FALSE)
)
} else if(input$toggle=='Probability View'){
df = filedata()
df = format(df, scientific = FALSE)
extensions <- list(
list(name = "sort"), #this enables/disables sorting
list( name = "colsVisibility",
text = 'Hide columns: ',
enable_tick_all = TRUE
),
list( name = "filtersVisibility",
visible_at_start = FALSE)
)
}
if(is.null(filedata())){
} else{
d3tf(df,
tableProps = tableProps,
extensions = extensions,
showRowNames = TRUE,
tableStyle = "table table-bordered")
}
})
# This line will end the R session when the Shiny app is closed
session$onSessionEnded(stopApp)
})
# Run app in browser
runApp(list(ui=ui,server=server), launch.browser = TRUE)
And here is a screen shot of it running: