Modify my rChart based on a reactive input? - r

I am having trouble with some code that I've written.
Here is a sample of the dataset: https://docs.google.com/spreadsheets/d/1C_P5xxzYr7HOkaZFfFiDhanqDSuSIrd2UkiC-6_G2q0/edit?usp=sharing
Objective:
I have a dataset that contains a column of Purchase_Month, candy and freq of the number of times that type of candy was purchased in that given month.
I have an rPlot which I was to change based on the chosen Candy bar in the SelectInput. And output a line chart based on the number of times that candy was purchased that month.
I have my current code below, but it tells me that candyCount is not found.
## ui.R ##
library(shinydashboard)
library(rCharts)
dashboardPage(
dashboardHeader(title = "Dashboard"),
dashboardSidebar(
width = 150,
sidebarMenu(
menuItem("Dashboard", tabName = "dashboard", icon = icon("bar-chart"))
)
),
dashboardBody(
sidebarPanel(
htmlOutput("candy")
),
mainPanel(
showOutput("plot2", "polycharts")
))
)
##server.R##
library(rCharts)
library(ggplot2)
library(ggvis)
server <- function(input, output, session) {
output$candy <- renderUI({
available2 <- dataset[(dataset$candy == input$candy), "candy"]
selectInput(
inputId = "candy",
label = "Choose a candy: ",
choices = sort(as.character(unique(available2))),
selected = unique(available2[1])
)
})
observeEvent(input$candy, {
candyChoice<- toString(input$customer_issue)
print(candyChoice)
candyCount<- dataset[dataset$candy == candyChoice, ]
})
})
output$plot2 <- renderChart2({
p2 <- rPlot(freq~purchase_month, data = candyCount, type = 'line')
p2$guides(y = list(min = 0, title = ""))
p2$guides(y = list(title = sprintf("%s Claims",input$candy)))
p2$addParams(height = 300, dom = 'chart2')
return(p2)
})
}
Updated Data: Why wouldn't this work?
candyCount<- reactive({
dataset[dataset$candy == input$candy, ]
})
output$plot2 <- renderChart2({
p2 <- rPlot(freq~purchase, data = candyCount(), type = 'line')
p2$guides(y = list(min = 0, title = ""))
p2$guides(y = list(title = ""))
p2$addParams(height = 300, dom = 'chart2')
return(p2)
})

output$candy <- renderUI({
available2 <- dataset[(dataset$candy == input$candy), "candy"]
selectInput(
inputId = "candy",
label = "Choose a candy: ",
choices = sort(as.character(unique(available2))),
selected = unique(available2[1])
)
})
In the above you are trying to subset by an input, which is inside your output. The selectInput needs to be inside UI.R.
A working basic example you may find useful.
library(shiny)
df <- read.csv("/path/to/my.csv")
ui <- shinyUI(pageWithSidebar(
headerPanel('Candy Data'),
sidebarPanel(
selectInput('candy', 'Candy', unique(as.character(df[,2])), selected = "Twix")
),
mainPanel(
plotOutput('plot1')
)
))
server <- shinyServer(function(input, output, session) {
selectedData <- reactive({
df[which(df[,2] == input$candy),3]
})
output$plot1 <- renderPlot({
barplot(selectedData())
})
})
shinyApp(ui, server)
In the above example the ui renders a selectInput which has the ID candy. The value, i.e the candy selected is now assigned to input$candy scope. In server we have a reactive function watching for any input change. When the user selects a new candy this function, df[which(df[,2] == input$candy),3] is saying "subset my data frame, df, by the new input$candy". This is now assigned to the selectedData(). Finally we render then boxplot.
EDIT
server.R
require(rCharts)
options(RCHART_WIDTH = 500)
df <- read.csv("path/to/my.csv")
shinyServer(function(input, output, session) {
selectedData <- reactive({
df[which(df[,2] == input$candy),]
})
output$plot1 <- renderChart({
p <- rPlot(freq~purchase_month, data = selectedData(), type = "line")
p$addParams(dom = 'plot1')
return(p)
})
})
ui.R
require(rCharts)
options(RCHART_LIB = 'polycharts')
shinyUI(pageWithSidebar(
headerPanel('Candy Data'),
sidebarPanel(
selectInput('candy', 'Candy', unique(as.character(df[,2])), selected = "Twix")
),
mainPanel(
showOutput('plot1', 'polycharts')
)
))
save files in directory and then runApp.

At available2 you're filtering the data about a selected candy with dataset$candy == input$candy. But you use the same available2 to determine which are the choices at selectInput. I'm guessing you wanted: available2 <- dataset[, "candy"].

Related

Loading bar from Waiter package doesn't disappear after its use [SHINY]

I am creating a Shiny app and I have started using the Waiter package.
When I load the app, before doing anything, we cannot see anything (at it is expected). When I generate the plot, the loading bar appears but when it finishes, it doesn't disappear. It stays a white box that it still can be seen.
Loading....
It has finished.
Does anyone know how to remove it?
Thanks in advance!
Code:
library(shiny)
library(magrittr)
library(DT)
library(ggplot2)
library(waiter)
new_choices <- setNames(names(mtcars), names(mtcars))
ui <- fluidPage(
# Application title
titlePanel("My shiny app"),
sidebarLayout(
sidebarPanel(
tabsetPanel(
tabPanel("Selection",
selectInput("x_axis", "Choose x axis",
choices = new_choices),
selectInput("y_axis", "Choose y axis",
choices = new_choices),
hr(),
),
tabPanel("Titles",
hr(),
textInput(inputId = "title", "You can write the title:", value = "This is the title"),
textInput(inputId = "xlab", "You can re-name the x-axis:", value = "x-axis...."),
textInput(inputId = "ylab", "You can re-name the y-axis:", value = "y-axis ...."),
),
tabPanel("Calculations",
hr(),
checkboxInput("log2", "Do the log2 transformation", value = F),
checkboxInput("sqrt", "Calculate the square root", value = F),
)
),
useWaitress(),
actionButton(inputId = "drawplot", label = "Show the plot")
),
# Show a plot of the generated distribution
mainPanel(
plotOutput("plot"),
)
)
)
server <- function(input, output, session) {
waitress <- Waitress$new(theme = "overlay-percent", min = 0, max = 10)
data <- reactive({
mtcars
})
filtered_data <- reactive({
data <- data()
if(input$log2 == TRUE){
data <- log2(data+1)
}
if(input$sqrt == TRUE){
data <- sqrt(data)
}
return(data)
})
v <- reactiveValues()
observeEvent(input$drawplot, {
# use notification
waitress$notify()
for(i in 1:10){
waitress$inc(1) # increase by 10%
Sys.sleep(.3)
}
v$plot <- ggplot() +
geom_point(data = filtered_data(),
aes_string(x = input$x_axis, y = input$y_axis)) +
xlab(input$xlab) +
ylab(input$ylab) +
ggtitle(input$title)
waitress$close() # hide when done
})
output$plot <- renderPlot({
if (is.null(v$plot)) return()
v$plot
})
}
shinyApp(ui, server)
Feels like a bug to me. You may file an issue to the waiter github repository and ask them to fix it. Meanwhile, a workaround we can do is to manually show and hide the bar by ourselves.
library(shiny)
library(magrittr)
library(DT)
library(ggplot2)
library(waiter)
library(shinyjs)
new_choices <- setNames(names(mtcars), names(mtcars))
ui <- fluidPage(
# Application title
titlePanel("My shiny app"),
sidebarLayout(
sidebarPanel(
tabsetPanel(
tabPanel("Selection",
selectInput("x_axis", "Choose x axis",
choices = new_choices),
selectInput("y_axis", "Choose y axis",
choices = new_choices),
hr(),
),
tabPanel("Titles",
hr(),
textInput(inputId = "title", "You can write the title:", value = "This is the title"),
textInput(inputId = "xlab", "You can re-name the x-axis:", value = "x-axis...."),
textInput(inputId = "ylab", "You can re-name the y-axis:", value = "y-axis ...."),
),
tabPanel("Calculations",
hr(),
checkboxInput("log2", "Do the log2 transformation", value = F),
checkboxInput("sqrt", "Calculate the square root", value = F),
)
),
useWaitress(),
useShinyjs(),
actionButton(inputId = "drawplot", label = "Show the plot")
),
# Show a plot of the generated distribution
mainPanel(
plotOutput("plot")
)
)
)
server <- function(input, output, session) {
waitress <- Waitress$new(theme = "overlay-percent", min = 0, max = 10)
data <- reactive({
mtcars
})
filtered_data <- reactive({
data <- data()
if(input$log2 == TRUE){
data <- log2(data+1)
}
if(input$sqrt == TRUE){
data <- sqrt(data)
}
return(data)
})
v <- reactiveValues()
observeEvent(input$drawplot, {
# use notification
show(selector = '.waitress-notification.notifications')
waitress$notify()
for(i in 1:10){
waitress$inc(1) # increase by 10%
Sys.sleep(.3)
}
v$plot <- ggplot() +
geom_point(data = filtered_data(),
aes_string(x = input$x_axis, y = input$y_axis)) +
xlab(input$xlab) +
ylab(input$ylab) +
ggtitle(input$title)
waitress$close()
hide(selector = '.waitress-notification.notifications')
})
output$plot <- renderPlot({
if (is.null(v$plot)) return()
v$plot
})
}
shinyApp(ui, server)

Shiny Application for Linear Regression with dynamic variable dropdown based on user upload

As the title describes, I'm simply trying to create a shiny application that allows the user to generate linear regression plots based on an imported csv file. After importing the file the dropdown for the variables of interest should be dynamically updated.
As the code below shows, I'm able to accomplish that with mtcars but I'm not able to do the same with an imported files that would have different dependent and independent variables .
Thank you for your help
data(mtcars)
cols <- sort(unique(names(mtcars)[names(mtcars) != 'mpg']))
ui <- fluidPage(
titlePanel("Build a Linear Model for MPG"),
sidebarPanel(
#fluidRow(
#column(4,
#tags$h3('Build a Linear Model for MPG'),
fileInput(
inputId = "filedata",
label = "Upload data. csv",
accept = c(".csv")
),
fileInput(
inputId = "filedata1",
label = "Upload data. csv",
accept = c(".csv")
),
selectInput('vars',
'Select dependent variables',
choices = cols,
selected = cols[1:2],
multiple = TRUE)
#)
), #sidebarpanel
mainPanel( column(4, verbatimTextOutput('lmSummary')),
column(4, plotOutput('diagnosticPlot')))
) #fluidpage
server <- function(input, output) {
data <- reactive({
req(input$filedata)
read.csv(input$filedata$datapath) %>% rename_all(tolower) %>%
filter(driver_name == input$driver_name & county == input$county & model == input$model)
})
lmModel <- reactive({lm(sprintf('mpg ~ %s', paste(input$vars, collapse = '+')),
data = mtcars)})
# lmModel <- reactive({lm(sprintf('mpg ~ %s', paste(input$vars, collapse = '+')),
# data = mtcars)})
output$lmSummary <- renderPrint({
summary(lmModel())
})
output$diagnosticPlot <- renderPlot({
par(mfrow = c(2,2))
plot(lmModel())
})
}
shinyApp(ui = ui, server = server)```
To dynamically select x and y axis variables, you can try the following
ui <- fluidPage(
titlePanel("Build a Linear Model"),
sidebarPanel(
fileInput(
inputId = "filedata",
label = "Upload data. csv",
multiple = FALSE,
accept = c(".csv"),
buttonLabel = "Choosing ...",
placeholder = "No files selected yet"
),
uiOutput("xvariable"),
uiOutput("yvariable")
), #sidebarpanel
mainPanel( #DTOutput("tb1"),
fluidRow(column(6, verbatimTextOutput('lmSummary')) , column(6, plotOutput('diagnosticPlot')))
)
) #fluidpage
server <- function(input, output) {
data <- reactive({
req(input$filedata)
inData <- input$filedata
if (is.null(inData)){ return(NULL) }
mydata <- read.csv(inData$datapath, header = TRUE, sep=",")
})
output$tb1 <- renderDT(data())
output$xvariable <- renderUI({
req(data())
xa<-colnames(data())
pickerInput(inputId = 'xvar',
label = 'Select x-axis variable',
choices = c(xa[1:length(xa)]), selected=xa[1],
options = list(`style` = "btn-info"))
})
output$yvariable <- renderUI({
req(data())
ya<-colnames(data())
pickerInput(inputId = 'yvar',
label = 'Select y-axis variable',
choices = c(ya[1:length(ya)]), selected=ya[2],
options = list(`style` = "btn-info"))
})
lmModel <- reactive({
req(data(),input$xvar,input$yvar)
x <- as.numeric(data()[[as.name(input$xvar)]])
y <- as.numeric(data()[[as.name(input$yvar)]])
if (length(x) == length(y)){
model <- lm(x ~ y, data = data(), na.action=na.exclude)
}else model <- NULL
return(model)
})
output$lmSummary <- renderPrint({
req(lmModel())
summary(lmModel())
})
output$diagnosticPlot <- renderPlot({
req(lmModel())
par(mfrow = c(2,2))
plot(lmModel())
})
}
shinyApp(ui = ui, server = server)
Addressing the dynamic menu:
Your selectInput element must be placed in the server section for it to be reactive. Things in the ui section are basically static. Use a uiOutput in the ui section and renderUI in the server section.
ui section (in place of selectInput block): uiOutput("var_select_ui")
server section (add):
output$var_select_ui <- renderUI({
cols <- colnames(data())
selectInput(
'vars',
'Select dependent variables',
choices = cols,
selected = cols[1:2],
multiple = TRUE
)
})

EDIT: Edited values in a datatable are not passed as choices in a selectInput()

I have a simple shiny app:
#ui.r
navbarPage(
"Application",
tabPanel("General",
sidebarLayout(
sidebarPanel(
uiOutput("tex2"),
uiOutput("book3")
),
mainPanel(
DT::dataTableOutput("hot3")
)
)))
#server.r
library(shiny)
library(DT)
server <- function(input, output,session) {
output$tex2<-renderUI({
numericInput("text2","#tests",
value = 1,
min=1
)
})
output$book3<-renderUI({
selectInput("bk3",
"Change Name",
choices=(rt1()[,1]))
})
rt1<-reactive({
data.frame(
Label=paste("Test",1:input$text2),
stringsAsFactors = FALSE)
})
output$hot3 <-DT::renderDataTable(
rt1(),
editable = TRUE
)
}
As you can see I have an editable datatable and I pass its label values to the selectInput() "Change Name". The problem is that when I edit the Labels in the datatable the values in the selectInput() do not change accordingly.
If I correctly understand what you want to do, I think this is not possible with DT.
This is possible with the D3TableFilter package (available on Github only so far). Please run this code and say me if this is indeed what you want to do:
library(shiny)
library(htmlwidgets)
library(D3TableFilter) # devtools::install_github("ThomasSiegmund/D3TableFilter")
ui <- navbarPage(
"Application",
tabPanel("General",
sidebarLayout(
sidebarPanel(
uiOutput("tex2"),
uiOutput("book3")
),
mainPanel(
d3tfOutput("hot3")
)
)
)
)
server <- function(input, output, session) {
output$tex2<-renderUI({
numericInput("text2", "#tests", value = 1, min=1)
})
rt1 <- reactiveVal(
data.frame(
Label = "Test 1",
stringsAsFactors = FALSE)
)
observe({
if(is.null(input$text2)) return(NULL)
rt1(
data.frame(
Label = paste("Test", 1:input$text2),
stringsAsFactors = FALSE)
)
})
output$book3 <- renderUI({
selectInput("bk3", "Change Name", choices=rt1()[,1])
})
output$hot3 <- renderD3tf({
# Define table properties. See http://tablefilter.free.fr/doc.php for a complete reference
tableProps <- list(
btn_reset = TRUE,
col_types = c("string", "string") # alphabetic sorting for the row names column
)
d3tf(rt1(),
tableProps = tableProps,
extensions = list(
list(name = "sort")
),
showRowNames = TRUE,
tableStyle = "table table-bordered",
edit = TRUE)
})
observe({
if(is.null(input$hot3_edit)) return(NULL);
edit <- input$hot3_edit;
isolate({
# need isolate, otherwise this observer would run twice for each edit
row <- as.integer(edit$row);
val <- edit$val;
dat <- rt1()
dat[,"Label"][row] <- val
rt1(dat)
})
})
}
shinyApp(ui, server)
Adapting the answer from Stéphane Laurent using DT gives the below:
library(shiny)
library(DT)
ui <- navbarPage(
"Application",
tabPanel("General",
sidebarLayout(
sidebarPanel(
uiOutput("tex2"),
uiOutput("book3")
),
mainPanel(
DTOutput("hot3")
)
)
)
)
server <- function(input, output, session) {
output$tex2<-renderUI({
numericInput("text2", "#tests", value = 1, min=1)
})
rt1 <- reactiveVal(
data.frame(
Label = "Test 1",
stringsAsFactors = FALSE)
)
observe({
if(is.null(input$text2)) return(NULL)
rt1(
data.frame(
Label = paste("Test", 1:input$text2),
stringsAsFactors = FALSE)
)
})
output$book3 <- renderUI({
selectInput("bk3", "Change Name", choices=rt1()[,1])
})
output$hot3 <- renderDT({
datatable(rt1(), editable = TRUE)
})
observe({
if(is.null(input$hot3_cell_edit)) return(NULL);
edit <- input$hot3_cell_edit;
isolate({
# need isolate, otherwise this observer would run twice for each edit
row <- as.integer(edit$row);
val <- edit$value;
dat <- rt1()
dat[,"Label"][row] <- val
rt1(dat)
})
})
}
shinyApp(ui, server)

Creating reactive renderUI

I am following this tutorial to learn to build Shiny apps. In the final version, the renderUI() for "Country" just takes all of the countries in the dataset. Is there a way to make this list reactive/filtered based on the price range selected with the slider?
Here is the relevant code:
output$countryOutput <- renderUI({
selectInput("countryInput", "Country",
sort(unique(bcl$Country)),
selected="CANADA")
})
And here is the entire. very simple app:
library(shiny)
library(ggplot2)
library(dplyr)
bcl <- read.csv("bcl-data.csv", stringsAsFactors = FALSE)
ui <- fluidPage(
titlePanel("BC Liquor Prices", windowTitle = "Mmmmm yeh"),
sidebarLayout(
sidebarPanel(
sliderInput("priceInput", "Price",
min = 0, max = 100,
value = c(25, 40), pre = "$"
),
radioButtons("typeInput", "Product type",
choices = c("BEER", "REFRESHMENT", "SPIRITS", "WINE"),
selected = "WINE"
),
uiOutput("countryOutput")
),
mainPanel(plotOutput("coolplot"),
br(),
br(),
tableOutput("results")
)
)
)
server <- function(input, output, session) {
filtered <- reactive({
if (is.null(input$countryInput)) {return(NULL)}
bcl %>%
filter(
Price >= input$priceInput[1],
Price <= input$priceInput[2],
Type == input$typeInput,
Country == input$countryInput
)
})
output$countryOutput <- renderUI({
selectInput("countryInput", "Country",
sort(unique(bcl$Country)),
selected="CANADA")
})
output$coolplot <- renderPlot({
if (is.null(filtered())) {return()}
ggplot(filtered(), aes(Alcohol_Content)) + geom_histogram()
})
output$results <- renderTable({
filtered()
})
}
shinyApp(ui = ui, server = server)
Try this code...You need two different reactive values: 1) One to generate the country list based on first two inputs and 2) Two two generate the plot and table results based on the selected country.
Also, I changed the names to reflect the actual column names I get when reading that file. You may need to change back IF you changed them in some other part of the code.
library(shiny)
library(ggplot2)
library(dplyr)
bcl <- read.csv("bcl-data.csv", stringsAsFactors = FALSE)
ui <- fluidPage(
titlePanel("BC Liquor Prices", windowTitle = "Mmmmm yeh"),
sidebarLayout(
sidebarPanel(
sliderInput("priceInput", "Price",
min = 0, max = 100,
value = c(25, 40), pre = "$"
),
radioButtons("typeInput", "Product type",
choices = c("BEER", "REFRESHMENT", "SPIRITS", "WINE"),
selected = "BEER"
),
uiOutput("countryOutput")
),
mainPanel(plotOutput("coolplot"),
br(),
br(),
tableOutput("results")
)
)
)
server <- function(input, output, session) {
filteredForCountry <- reactive({
bcl %>%
filter(
CURRENT_DISPLAY_PRICE >= input$priceInput[1],
CURRENT_DISPLAY_PRICE <= input$priceInput[2],
PRODUCT_SUB_CLASS_NAME == input$typeInput
)
})
output$countryOutput <- renderUI({
df <- filteredForCountry()
if (!is.null(df)) {
selectInput("countryInput", "Country",
sort(unique(df$PRODUCT_COUNTRY_ORIGIN_NAME)),
selected="CANADA")
}
})
filteredFull <- reactive({
if (is.null(input$countryInput)) {
return (filteredForCountry())
}
bcl %>%
filter(
CURRENT_DISPLAY_PRICE >= input$priceInput[1],
CURRENT_DISPLAY_PRICE <= input$priceInput[2],
PRODUCT_SUB_CLASS_NAME == input$typeInput,
PRODUCT_COUNTRY_ORIGIN_NAME == input$countryInput
)
})
output$coolplot <- renderPlot({
if (is.null(filteredFull())) {return()}
ggplot(filteredFull(), aes(PRODUCT_ALCOHOL_PERCENT)) +
geom_histogram(binwidth = 0.05)
})
output$results <- renderTable({
filteredFull()
})
}
shinyApp(ui = ui, server = server)

Trouble with a Reactive Input in ShinyDashboard

I am using the following dataset: https://docs.google.com/spreadsheets/d/1C_P5xxzYr7HOkaZFfFiDhanqDSuSIrd2UkiC-6_G2q0/edit#gid=0
I am using ShinyDashboard and I have a selectInput that allows me to choose a specific type of Candy bar (in the Candy column in my data set).
How do I take that Candy selection, and then make a graph that contains the frequency for that selected candy bar for each purchase month? In my server.R, I am not sure what to have in that CandyCount reactive element.
My code is as follows:
## ui.R ##
library(shinydashboard)
library(rCharts)
dashboardPage(
dashboardHeader(title = "Dashboard"),
dashboardSidebar(
width = 150,
sidebarMenu(
menuItem("Dashboard", tabName = "dashboard", icon = icon("bar-chart"))
)
),
dashboardBody(
sidebarPanel(
htmlOutput("candy")
),
mainPanel(
showOutput("plot2", "polycharts")
)))
##server.R##
server <- function(input, output, session) {
output$candy<- renderUI({
selectInput(
inputId = "candy",
label = "Candy: ",
choices = as.character(unique(dataset$Candy)),
selected = "Twix"
)
})
output$plot2 <- renderChart2({
candySelect<- input$candy
df <- dataset[dataset$candy == candySelect,]
p2 <- rPlot(freq~purchase_month, data = df, type = 'line')
p2$guides(y = list(min = 0, title = ""))
p2$guides(y = list(title = ""))
p2$addParams(height = 300, dom = 'chart2')
return(p2)
})
}
If your okay with using ggplot you could do something like this:
Edited to have dynamic tooltip
## ui.R ##
library(shinydashboard)
library(shinyBS)
require(ggplot2)
dataset <- read.csv("Sample Dataset - Sheet1.csv")
ui <- dashboardPage(
dashboardHeader(title = "Dashboard"),
dashboardSidebar(
width = 150,
sidebarMenu(
menuItem("Dashboard", tabName = "dashboard", icon = icon("bar-chart"))
)
),
dashboardBody(
sidebarPanel(
htmlOutput("candy")
),
mainPanel(
uiOutput("plotUI")
)
))
##server.R##
server <- function(input, output, session) {
output$candy<- renderUI({
selectInput(
inputId = "candy",
label = "Candy: ",
choices = as.character(unique(dataset$Candy)),
selected = "Twix"
)
})
output$plotUI <- renderUI({
if(is.null(input$candy)) return(NULL)
local({
candySelect <- input$candy
str1 <- sprintf("The candybar you selected is: %s",candySelect)
str2 <- sprintf("More about %s <a>here</a>",candySelect)
print (str1)
popify(plotOutput('plot'),str1,str2)
})
})
observeEvent(input$candy,{
if(is.null(input$candy)) return(NULL)
candySelect<- input$candy
print ('plot')
# Assuming only one entry for each mont per candybar
d <- dataset[dataset$Candy==candySelect,]
output$plot <- renderPlot({
ggplot(data=d, aes(x=purchase_month,y=freq,group=Candy)) +
geom_line() +
ggtitle(candySelect)
})
})
}
shinyApp(ui = ui, server = server)
I guess this should work otherwise you can bind tooltips using jQuery.

Resources