Using R shiny, I am developing a simple app that allows user to input data from a Rdata file. I want the app to load the data, show the names of numeric variables in a select input field, and after the user selected one of variables do some analysis. But I can not get it working. In the code provided I obtain two outputs: summary, which works fine, and the MEAN of the selected variable which I can not get work.
server.R
library(shiny)
library(shinydashboard)
library(data.table)
library(DT)
shinyServer(function(input, output) {
#### DATA LOAD
df <- reactive({
df <- input$datafile
if (is.null(df)) {
# User has not uploaded a file yet
return(NULL)
}
objectsLoaded <- load(input$datafile$name)
# the above returns a char vector with names of objects loaded
df <- eval(parse(text=objectsLoaded[1]))
# the above finds the first object and returns it
df<-data.table(df)
})
#### SELECTS
num <- reactive({
num <- sapply(df(),is.numeric)
num <- names(num)
})
output$var_num <- renderUI({
vector.num <- as.vector(num())
selectInput("var_num", "Select Variables :", as.list(vector.num), multiple = FALSE)
})
#### OUTPUTS
### SUMMARY
output$summary_num <-renderDataTable({
x<-t(sapply(df(), summary))
x<-as.data.frame(x)
x<-setDT(x, keep.rownames = TRUE)[]
colnames(x) <- c("Variable","Mínimo","1er Quartil", "Mediana", "Media", "3er Quartil","Máximo")
datatable(x)
})
### MEAN OF SELECTED VAR
output$test <-renderPrint ({
if(is.null(df()))
return()
dat<- df()
dat <- dat[,num(), drop = FALSE]
mean(dat[,input$var_num])
})
})
UI.R
dashboardPage(
dashboardHeader(title = "TITLE", titleWidth = 500),
dashboardSidebar(disable = TRUE), #---> fin SIDEBAR
dashboardBody(
fluidRow(
box(width=12, status = "primary",
tabsetPanel(
tabPanel("Test",
fileInput("datafile", label = h3("File input")),
uiOutput("var_num"),
br(),hr(),br(),
fluidRow(column(width=4, uiOutput("var_caracter"),textOutput("test"))),
br(),hr(),br(),
fluidRow(column(width=8, "Variables Numericas", dataTableOutput("summary_num")))
)
) # fin tabsetPanel
) # fin box
)# fin fluidRow
)# fin dashboardBody
)# fin dashboardPage
When I run the app everything goes fine (select input, summary, etc) except the calculation and printing of the MEAN of the selected variable. I guess for some reason the subsetted dataframe is empty, but I do not know why...
Any help will be great! Thanks in advance.
I get it working.
The solution was to define the dataset I used as.data.frame:
### MEAN OF SELECTED VAR
output$test <-renderPrint ({
if(is.null(df()))
return()
dat<- as.data.frame(df()) ## THIS IS THE CORRECTION
dat <- dat[,num(), drop = FALSE]
mean(dat[,input$var_num])
})
I do not really understand why... The reactive file df() was defined as data.table and dat shoul inherit that, but for some reason it was necesary an explicit definition as dataframe.
Related
My goal is that user uploads an Excel file. Then, the user selects which sheets wants to be summarised, after the selection has been updated. I have managed to update selectInput with the name of the sheets but I have not been able to find\understand how to summarise based on what the sheet selected by the user. Thanks for any help.
library(shiny)
library(shinythemes)
library(data.table)
library(ggplot2)
library(dplyr)
library(readxl)
not_sel <- "Not Selected"
# Define UI for application that draws a histogram
ui <- fluidPage('MAIN TITLE',
theme = shinytheme('flatly'),
tabsetPanel(
sidebarLayout(
sidebarPanel(
fileInput('files','Import File', accept = c('.csv','.xlsx'),
multiple = F),
actionButton('boton1', 'Load', icon = icon('table')),
br(),
selectInput("indices", "Select SHEET:", choices = c(not_sel))
),
mainPanel(
tabsetPanel(
tabPanel('Data',
tableOutput('tabla'),
tableOutput('cabeza')),
tabPanel('Stats',
# selectInput('var01', 'Variable to summarise', choices = c(not_sel)),
tableOutput('stats')),
)
)
)
)
)
##############
server <- function(input, output, session) {
options(shiny.maxRequestSize=10*1024^2)
df <- eventReactive(input$boton1, {
req(input$files)
if(is.null(input$files))return(NULL)
# else{
read_excel(input$files$datapath)
# }
})
# Sheets of file uploaded
sheets_name <- reactive({
if (!is.null(input$files)) {
return(excel_sheets(path = input$files$datapath))
} else {
return(NULL)
}
})
# Update inputSelector with sheet names
observeEvent(df(),{
choices <- c(sheets_name())
updateSelectInput(inputId = "indices", choices = choices)
})
# DATA Tab
## This will show the name of the file
output$tabla <- renderTable({
input$files$name
})
## This Shows the head() but it is only showing the first sheet
output$cabeza <- renderTable({
tabla <- as_tibble(bind_cols(Date = format(as.Date(df()$Date),"%Y-%m-%d"),
Close.Price = df()$Close))
head(tabla)
})
# HERE is where I do not know how to calculate based on selection
# Table for STATS
output$stats <- renderTable({
datos <- df()
Value <- c(round(mean(datos$Close,na.rm = T),2)
)
Statistic <- c("Mean")
data.table(Statistic, Value)
})
}
# Run the application
shinyApp(ui = ui, server = server)
I want to assume that by knowing how to calculate mean based on the sheet selected, I. can replicate the code for the top rows (head()) shown in the Data Panel.
If I missed a similar question asked, I would appreciate any link and I will try the solution proposed first.
As I cannot share the file, this is how the file would look:
After working with this answer I made my app work. If there is a 'cleaner'/'better' answer, I will be happy to read.
Following the recommendation in the linked answer my server ended up like this:
ui <-fluidPage{
#My UI stayed the same with the exception of adding
uiOutput("dropdownUI") #Whererever I needed to appear
}
server <- function(input, output, session) {
...ANSWER FROM THE LINK...
## STATS Tab
output$stats <- renderTable({
Values <- c(round(mean(Dat()[,2],na.rm = T),2)
)
Statistics <- c("Mean")
data.table(Statistics, Values)
})
}
List item
I have a problem with reactive values not working as i think it should work.
The small code below describes the problem. The function firstsub2 will basically subset an object into a smaller one by removing samples we don´t want to keep for some reason (this is using the subset_samples function from the phyloseq biocondcutor package).
UI.R
myui <-
fluidPage(
navbarPage("Project",
## foldchanges
tabPanel("Foldchanges",
titlePanel("Permanova: Analysis of variance using distance matrices"),
# Sidebar layout with input and output definitions ----
sidebarLayout(
# Sidebar panel for inputs ----
sidebarPanel(
actionButton("dofoldchanges", "Generate foldchanges")
),
mainPanel(
# Output: Tabset w/ plot, summary, and table ----
tabsetPanel(id="foldchanges",type = "tabs",
tabPanel(title="Summary", value=1, verbatimTextOutput("summary_foldchanges"))
#tabPanel("Table pairwise",value=4, dataTableOutput("tablepermanovapw"))
)
)
)
)
)
)
SERVER.R
#To install phyloseq
#source("https://bioconductor.org/biocLite.R")
#biocLite("phyloseq")
library(shiny)
library(phyloseq)
myserver <- function(input, output, session) {
source("foldchanges.R", local = TRUE)
}
foldchanges.R
# Filter object
firstsub2 <- reactive({
values$rn <- as.character(sample_data(values$physeq)[,"Description"]$Description)))
cat(values$rn)
#The subset_samples function below will not work
filteredtaxo <- subset_samples(values$physeq, Description %in% values$rn)
return(filteredtaxo)
})
values <- reactiveValues()
observeEvent(input$dofoldchanges, {
rich_sparse_biom = system.file("extdata", "rich_sparse_otu_table.biom", package = "phyloseq")
physeq = import_biom(rich_sparse_biom, parseFunction = parse_taxonomy_greengenes)
print(physeq)
values$physeq <- physeq
values$filtered <- firstsub2()
})
This example will basically return the same object that was imported
Your code still has some errors, especially the server file (Some unnecessary commas).
I think your app works as it should, but it will always be the same file as the values$rn will always be the same. I included another line (uncommented right now) below your subset_sample, to test if the subsetting is working. If you change values$rn to "human skin" for example, you will see different results.
But I didn't figure out how to change it. When taking only the first element of values$rn for example, I'm getting an object not found error. But when I include "human skin" like that, it works.
But maybe that helps you already.
library(shiny)
# source("https://bioconductor.org/biocLite.R")
# biocLite("phyloseq")
library(phyloseq)
myui <- {fluidPage(
navbarPage("Project",
## foldchanges
tabPanel("Foldchanges",
titlePanel("Permanova: Analysis of variance using distance matrices"),
# Sidebar layout with input and output definitions ----
sidebarLayout(
# Sidebar panel for inputs ----
sidebarPanel(
actionButton("dofoldchanges", "Generate foldchanges")
),
mainPanel(
# Output: Tabset w/ plot, summary, and table ----
tabsetPanel(id="foldchanges",type = "tabs",
tabPanel(title="Summary", value=1,
verbatimTextOutput("summary_foldchanges"),
verbatimTextOutput("summary_physeq"))
)))))
)}
myserver <- function(input, output, session) {
values <- reactiveValues()
firstsub2 <- reactive({
req(values$physeq)
input$dofoldchanges
values$rn <- as.character(sample_data(values$physeq)[,"Description"]$Description)
cat(values$rn)
#The subset_samples function below will not work
filteredtaxo <- subset_samples(values$physeq, "Description" %in% values$rn)
## Change it to one of the next lines, to see that subsetting works.
# filteredtaxo <- subset_samples(values$physeq, Description %in% "human skin")
# filteredtaxo <- subset_samples(values$physeq, Description %in% "human gut")
return(filteredtaxo)
})
observeEvent(input$dofoldchanges, {
rich_sparse_biom = system.file("extdata", "rich_sparse_otu_table.biom", package = "phyloseq")
physeq = import_biom(rich_sparse_biom, parseFunction = parse_taxonomy_greengenes)
print(physeq)
values$physeq <- physeq
values$filtered <- firstsub2()
})
output$summary_physeq <- renderPrint({
req(values$physeq)
values$physeq
})
output$summary_foldchanges <- renderPrint({
req(values$filtered)
values$filtered
})
}
shinyApp(myui, myserver)
We have created a shiny application where either the user can upload a big dataset (RData file over 200MB) or they can pick one from us. Then there are three different tabs where the user can filter the data (tab for numerics, tab for categorics)
So currently I have 3 reactive functions to serve that purpose. But downside is that the object is kept three times in memory. Is there a more efficient way to do this?
Please find a simplified example app below:
note: in this app you only see 1 filter per tab. normally its more like this:
My_Filtered_Data[Species %in% input$filter1 &
x %in% input$x &
y %in% input$y &
z %in% input$z] #etc.
I was looking at reactiveValues but couldn't really find how it works.
Reason I don't want to have it in 1 reactive is that everytime I change one of the filters on one of the sheets, the entire filtering process starts again and that is quite time consuming. I'd prefer to have one dataset that that gets updated with only the filter that is used at that time. That's the reason I included the different reactives
## app.R ##
library(shinydashboard)
library(data.table)
CustomHeader <- dashboardHeader(title='datatest')
iris<-iris
ui <- function(request) {
dashboardPage(
CustomHeader,
## Sidebar content
dashboardSidebar(
sidebarMenu(
menuItem("filter1 & Import", tabName = "filter1", icon = icon("dashboard")),
menuItem("filter2", tabName = "filter2", icon = icon("th")),
menuItem("filter3", tabName = "filter3", icon = icon("th"))
)
),
## Body content
dashboardBody(
tabItems(
# First tab content
tabItem(tabName = "filter1",
fluidRow(box(width = 3,
selectInput(inputId = 'filter1','filter1:species',choices = unique(iris$Species))))
),
tabItem(tabName = "filter2",
fluidRow(box(width = 3,
sliderInput(inputId = 'filter2','filter2:Max.Sepal.Length',min = 0,max = 10,value = 10)
))
),
tabItem(tabName = "filter3",
fluidRow(box(width = 3,
sliderInput(inputId = 'filter3','filter3:Min.Sepal.Width',min = 0,max = 10,value = 0)
),
box(width=9,dataTableOutput('mydata')))
)
)
)
)
}
server <- function(input, output) {
My_Uploaded_Data <- reactive({
My_Uploaded_Data<-data.table(iris)
My_Uploaded_Data
})
My_Filtered_Data <- reactive({
My_Filtered_Data<-My_Uploaded_Data()
My_Filtered_Data[Species %in% input$filter1]
})
My_Filtered_Data2 <- reactive({
My_Filtered_Data2<-My_Filtered_Data()
My_Filtered_Data2[Sepal.Length < input$filter2]
})
My_Filtered_Data3 <- reactive({
My_Filtered_Data3<-My_Filtered_Data2()
My_Filtered_Data3[Sepal.Width > input$filter3]
})
output$mydata<-renderDataTable({
My_Filtered_Data3()
})
}
shinyApp(ui, server)
I was hoping something like tthis would work in reactiveValues
react_vals <- reactiveValues(data = NULL)
observe(react_vals$data <- MyLoadedData())
observe(react_vals$data <- react_vals$data[Species %in% input$filter1])
observe(react_vals$data <- react_vals$data[Sepal.Length < input$filter2])
observe(react_vals$data <- react_vals$data[Sepal.Width > input$filter3])
EDIT: I also would like to include bookmarks: https://shiny.rstudio.com/articles/advanced-bookmarking.html and it seems you need reactiveValues for that. So another reason for me to move away from all these reactives/eventReactive
Instead of storing datasets in the reactive variables, just store the rows which qualify. That way, each reactive value is only replaced when it's filter changes; they aren't linked together. The output just uses the rows which pass all filters.
At the top of the program, change iris to a data.table:
library(shinydashboard)
library(data.table)
CustomHeader <- dashboardHeader(title = 'datatest')
iris <- iris
setDT(iris) # Added
Then use this for the server logic:
server <- function(input, output) {
filter1_rows <- reactive({
iris[Species %in% input$filter1, which = TRUE]
})
filter2_rows <- reactive({
iris[Sepal.Length < input$filter2, which = TRUE]
})
filter3_rows <- reactive({
iris[Sepal.Width > input$filter3, which = TRUE]
})
output$mydata <- renderDataTable({
final_rows <- intersect(filter1_rows(), filter2_rows())
final_rows <- intersect(final_rows, filter3_rows())
iris[final_rows]
})
}
This uses the often-overlooked which argument for data.table[...], which means only the row numbers of the subsetted table should be returned.
I think your problem has nothing to do with shiny and/or reactive programming. It's a "classic time vs memory" situation. Basically speaking you have only two options: Store "partially" filtered objects or not.
If you do store them, you use a lot of memory but can return the object instantly. If not, you need only store the original object but you have to filter it everytime again. There is nothing in between. You just cannot create an object that is different from the original (i.e. filtered) but takes no additional memory, not even with reactiveValues.
Of course you can do tradeoffs, e.g. creating an intermediate object for the first filter and computing the second and the third filter on-the-fly, but that does not change the underlying problem.
I'm very new to shiny and am having some trouble and have been searching all day, so hopefully someone can help me. Once an action button (actionButton, on UI) is selected by a user, I would like the server script to call a function (evenReactive in server) I wrote (myfunction, see below) that uses the input items from the UI and gets the right parameters I need to run myfunction and produce a n X2 data matrix that will be plotted as a table (renderTable in server, below). The data is a n X 2 matrix.
I have some sample code below. It's not the entre code, so you will not see the UI with the inputs I am putting in my function, or the server parts associated. But, it is the part I am trying to fix. I hope that's ok. I don't need the renderText, but when I take it out I get an error. Sorry for the formatting. Copy and pasting changed it a bit.
library(shiny)
ui <- shinyUI(fluidPage
(column(4,actionButton("gobutton", "Run"),verbatimTextOutput("ntext1")),
column(4, DT::dataTableOutput("table",width = "75%"))))
library(shiny)
shinyServer(function(input, output, session)
ntext1 <- eventReactive(input$gobutton, {
if (input$gobutton==1){
data=myfunction(input$checkbox,input$dateRange)}
})
output$ntext1 <- renderText({ntext1()})
output$table <- DT::renderDataTable(DT::datatable({
data
})
))
myfunction <-function(All,date1,date2,source_cd,tran_cd,airline_list,mag_level) {
print(All); print(date1); print(date2); print(source_cd);print(tran_cd);print(airline_list);print(mag_level)
setwd("C:/Users/TRomano/Documents/Projects/TrendAnalysis/Data")
data = read.csv("Airlines.csv",header = TRUE)
return(data)
}
For this type of problem I like to make use of reactiveValues()that are designed to store data in a reactive way.
Here is a simple app (single app, not split into server & ui) that demonstrates what I think you are trying to do
library(shiny)
library(DT)
ui <- shinyUI(
fluidPage(
column(width = 4,
actionButton("gobutton", "Run")
column(width = 4,
DT::dataTableOutput("table",
width = "75%"))))
server <- shinyServer(function(input, output, session){
rv <- reactiveValues()
rv$data <- NULL
observe({ ## will 'observe' the button press
if(input$gobutton){
print("here") ## for debugging
rv$data <- myfunction() ## store the data in the reactive value
rv$data
}
})
output$table <- DT::renderDataTable({
## The data has been stored in our rv, so can just return it here
rv$data
})
})
myfunction <- function(){
data <- data.frame(id = c(1,2,3),
val = letters[1:3])
return(data)
}
shinyApp(ui, server)
library(shiny)
library(shinydashboard)
ui <- dashboardPage(
dashboardHeader(title = "Company Name"),
dashboardSidebar(sidebarMenu(
menuItem("Results Table", tabName = "ResultsTable", icon = icon
("ResultsTable")),
dashboardBody(
tabItems(
tabItem(tabName tabItem(tabName = "ResultsTable",
fluidPage(
headerPanel(
fluidRow(
column(4,
selectInput("sour",
"Source Type:",
c("All",
unique(as.character(data_source_cd)))), offset=2
),
column(4,
selectInput("tran",
"Transaction Type:",
c("All",
unique(as.character(tran_cd)))))),
# Create a new row for the table.
fluidRow(column(8, DT::dataTableOutput("table",width = "75%"),offset = 2))))))
library(shiny)
shinyServer(function(input, output, session) {
ntext1 <- eventReactive(input$gobutton, {
if (input$dateRange[2]<input$dateRange[1]){print("You selected the date range option;however, the end date entered occurs before the starting date")}else{
output$ntext1 <- renderText({print("Analysis complete...")});
observe({
if(input$gobutton){
rv$data <- myfunction() }
})
output$table <- DT::renderDataTable(DT::datatable({
data <- rv$data
if (input$sour != "All") {
data <- data[data[,5] == input$sour,]
}else{data}
if (input$tran != "All") {
data <-data[data[,6] == input$tran,]
}else{data}
}))
}})
Once an action button is selected on the main page of my dashboard(not shown), myfunction runs analysis with the inputs from the main dashboard page. On another tab, a table will show once the analysis is complete. There are drop down menus (input$tran, input$sour) that will reduce what is in the table depending on what the user selects. If there are any errors in the input, a warning of text comes up on the main dashboard page and the tab with the table will not be created until the correct inputs are selected.
The observe function allowed me to run my function and the output data of the function set to a variable I could later use to create the table (shown).
THis is my first time posting. Any questions feel free to ask.
I'm building a shiny app that queries an SQL database so the user can ggplot the data. I would like the user to be able to rename factors manually but am struggling to get going. Here is an example of what I want to do:
ui.R
library(markdown)
shinyUI(fluidPage(
titlePanel("Reactive factor label"),
sidebarLayout(
sidebarPanel(
numericInput("wafer", label = h3("Input wafer ID:"), value = NULL),
actionButton("do", "Search wafer"),
textInput("text", label = h3("Factor name to change"), value = ""),
textInput("text", label = h3("New factor name"), value = ""),
actionButton("do2", "Change name")
),
mainPanel(
verbatimTextOutput("waf"),
verbatimTextOutput("que"),
verbatimTextOutput("pos"),
dataTableOutput(outputId="tstat")
)
)
)
)
server.R
# Create example data
Name <- factor(c("Happy", "New", "Year"))
Id <- 1:3
dd <- data.frame(Id, Name)
con <- dbConnect(RSQLite::SQLite(), ":memory:")
dbWriteTable(con, "dd", dd)
query <- function(...) dbGetQuery(con, ...)
wq = data.frame()
sq = data.frame()
shinyServer(function(input, output){
# create data frame to store reactive data set from query
values <- reactiveValues()
values$df <- data.frame()
# Wait for user to search
d <- eventReactive(input$do, { input$wafer })
# Reactive SQL query
a <- reactive({ paste0("Select * from dd where Id=",d()) })
wq <- reactive({ query( a() ) })
# Check outputs
output$waf <- renderPrint(input$wafer)
output$que <- renderPrint({ a() })
output$pos <- renderPrint( wq()[1,1] )
# observe d() so that data is not added until user presses action button
observe({
if (!is.null(d())) {
sq <- reactive({ query( a() ) })
# add query to reactive data frame
values$df <- rbind(isolate(values$df), sq())
}
})
output$tstat <- renderDataTable({
data <- values$df
})
})
In static R I would normally use data table to rename factors i.e.:
DT <- data.table(df)
DT[Name=="Happy", Name:="Sad"]
But I'm not sure how to go about this with a reactiveValues i.e. values$df.
I have read this (R shiny: How to get an reactive data frame updated each time pressing an actionButton without creating a new reactive data frame?). This lead me to try this but it doesn't do anything (even no error):
observeEvent(input$do2, {
DT <- data.table(values$df)
DT[Name == input$text1, Name := input$text2]
values$df <- data.frame(values$df)
})
Perhaps there is a way around this..maybe there is a way to use an action button to "lock in" the data as a new data frame, which can then be used to rename?
Sorry for such a long winded question. My real app is much longer and more complex. I have tried to strip it down.
Your approach works but there are a few issues in your app.
In ui.R, both textInput have the same id, they need to be different so you can refer to them in the server.R. In the observeEvent you posted, you refer to input$text1 and input$text2 so you should change the id of the textInputs to text1 and text2.
In the observeEvent you posted, the last line should be values$df <- as.data.frame(DT), otherwise it does not change anything.