Hide/Show table in R shiny based on input value - r

I am trying to show/hide a table based on the input selection. Based on my first dropdown if the user selects a value wave2 it should show the table 2 under the 1st tab else it should hide. I tried to use the react input select value to if else condition for output which is not how react works in R. Could someone please check and let me know on where I am wrong .
UI.r
library(shiny)
library(shinydashboard)
library(shinyBS)
library(shinythemes)
dashboardPage(
dashboardHeader(disable = F, title = "PATH Study"),
dashboardSidebar(
uiOutput("choose_wave"),
uiOutput("choose_category"),
uiOutput("choose_ethnicity"),
uiOutput("choose_age"),
uiOutput("choose_gender")
),
#S dashboardPage(header = dashboardHeader(), sidebar = dashboardSidebar(),body,title = NUll, skin = "yellow"),
dashboardBody(box(
width = 12,
tabBox(
width = 12,
id = "tabBox_next_previous",
tabPanel("Initiation",
fluidRow(
box(
title = "TABLE1",
width = 5,
solidHeader = TRUE,
status = "primary",
tableOutput("smoke"),
collapsible = T,
),
box(
title = "TABLE2",
width = 7,
solidHeader = TRUE,
status = "primary",
tableOutput("first_flov"),
collapsible = T
)
))
),
uiOutput("Next_Previous")
))
)
SERVER.r
library(shiny)
library(shinydashboard)
library(shinyBS)
library(knitr)
library(kableExtra)
library(plyr)
library(tidyverse)
library(DT)
library(dplyr)
shinyServer(function(input, output) {
print(sessionInfo())
with_demo_vars <- reactive({
data_selector(wave(), youth()) %>%
mutate(
ethnicity = !!ethnicity(),
age = !!age_group(),
gender = !!gender()
)
})
# Drop-down selection box for which Wave and User Type bracket to be selected
output$choose_wave <- renderUI({
# This can be static: it is the highest level and the options won't change
selectInput(
"selected_wave",
"Wave",
choices = list(
"Wave 1 Adult" = "wave1youthFALSE",
"Wave 1 Youth" = "wave1youthTRUE",
"Wave 2 Adult" = "wave2youthFALSE",
"Wave 2 Youth" = "wave2youthTRUE"
)
)
})
wave <- reactive({
as.integer(gsub("wave(\\d)youth.*", "\\1", input$selected_wave))
})
youth <- reactive({
as.logical(gsub("wave\\dyouth(.+)$", "\\1", input$selected_wave))
})
# Drop-down selection box for which Gender bracket to be selected
output$choose_ethnicity <- renderUI({
selectInput("selected_ethnicity", "Ethnicity", as.list(levels(with_demo_vars()$ethnicity)))
})
# Drop-down selection box for which Age bracket to be selected
output$choose_age <- renderUI({
selectInput("selected_age", "Age", as.list(levels(with_demo_vars()$age)))
})
# Drop-down selection box for which Gender bracket to be selected
output$choose_gender <- renderUI({
selectInput("selected_gender", "Gender", as.list(levels(with_demo_vars()$gender)))
})
output$selected_var <- renderText({
paste("You have selected", input$selected_wave)
})
myData <- reactive({
# wave_selected <- input$selected_wave
category_selected <- req(input$selected_category)
age_selected <- req(input$selected_age)
gender_selected <- req(input$selected_gender)
ethnicity_selected <- req(input$selected_ethnicity)
# TABLE 1
df<-data_selector(wave = 1, youth()) %>%
filter(!!is_ever_user(type = category_selected)) %>%
pct_first_flavored(type = category_selected)
df_sub <- names(df) %in% c("variable")
df <- df[!df_sub]
df
})
first_flov <- reactive({
category_selected <- req(input$selected_category)
age_selected <- req(input$selected_age)
gender_selected <- req(input$selected_gender)
ethnicity_selected <- req(input$selected_ethnicity)
first_flov_df <- data_selector(wave = 2, youth()) %>%
filter(!!is_new_user(type = category_selected)) %>% # this doesn't apply to wave 1
pct_first_flavored(type = category_selected)
first_flov_df_sub <- names(first_flov_df) %in% c("variable")
first_flov_df <- first_flov_df[!first_flov_df_sub]
first_flov_df
})
output$smoke <-
renderTable({
head(myData())
})
output$first_flov <-
if (wave() == 2) {
renderTable({
head(first_flov())
})
} else {
renderText({
paste("You have selected", input$selected_wave)
})
}
})

Related

Shiny output plot based on input inside bs_accordion

I have a set of inputs inside bs_accordion and would like to output a plot based on the selected inputs and active/expanded panel, but I'm not sure how to link the selected input based on this active/expanded panel. Is there a way to know which panel is active? My code is below and thank you in advance.
library(shiny)
library(bsplus)
library(shinyjs)
month_data <- data.frame(Region = c(rep("Region M1", 20), rep("Region M2", 20)),
Value = runif(40))
day_data <- data.frame(Region = c(rep("Region D3", 20), rep("Region D4", 20)),
Value = runif(40))
m1 <- selectInput(inputId = "in_month_region", label = "Region", choices = c("Region M1", "Region M2"))
d1 <- selectInput(inputId = "in_day_region", label = "Region", choices = c("Region D3", "Region D4"))
ui <- fluidPage(
useShinyjs(),
actionButton(inputId = "toggle_menu", label = "Options"),
br(),
sidebarLayout(
div(id = "Sidebar",
sidebarPanel(width = 3,
bs_accordion(id = "input_panel") %>%
bs_set_opts(panel_type = "success", use_heading_link = TRUE) %>%
bs_append(title = "Monthly",
content = m1) %>%
bs_append(title = "Daily",
content = d1))),
mainPanel(plotOutput("myplot"))
)
)
server <- function(input, output, session){
observeEvent(input$toggle_menu, {
shinyjs::toggle(id = "Sidebar")
})
get_data <- reactive({
if(!input$in_month_region %in% c(NULL, "")){
a <- subset(month_data, Region %in% input$in_month_region)
} else if(!input$in_day_region %in% c(NULL, "")){
a <- subset(day_dat, Region %in% input$in_day_region)
}
return(a)
})
output$myplot <- renderPlot({
mydat <- get_data()
plot(mydat$Value, main = unique(mydat$Region))
})
}
shinyApp(ui, server)

How to add comment to a reactive data table in shiny

This question is an extension of the question I posted: this question
I created a dataframe with 3 columns: num, id and val. I want my shiny app to do the following:
a dataframe dat is filtered by num column
select an value from id column from dat (selectInput).
add text comment in a text box (textInput)
click on an action button
A new column called comment is created in the data table, text comments are added to the comment column in the row where id equals the value selected.
The code is below. I cannot figure out why it's not working.
Thank a lot in advance!
library(shiny)
library(DT)
dat = data.frame(num=rep(1:2, each=5), id=rep(LETTERS[1:5],2), val=rnorm(10))
ui = fluidPage(
fluidRow(
column(12, selectInput('selectNum', label='Select Num',
choices=1:10, selected='')),
column(2, selectInput(inputId = 'selectID',
label = 'Select ID2',
choices = LETTERS[1:10],
selected='',
multiple=TRUE)),
column(6, textInput(inputId = 'comment',
label ='Please add comment in the text box:',
value = "", width = NULL,
placeholder = NULL)),
column(2, actionButton(inputId = "button",
label = "Add Comment"))
),
fluidRow (
column(12, DT::dataTableOutput('data') )
)
)
server <- function(input, output, session) {
## make df reactive
df = reactive ({ dat %>% filter(num %in% input$selectNum) })
df_current <- reactiveVal(df())
observeEvent(input$button, {
req(df_current())
## update df by adding comments
df_new <- df_current()
df_new[df_current()$id %in% input$selectID, "Comment"] <- input$comment
df_current(df_new)
})
output$data <- DT::renderDataTable({
req(df_current())
DT::datatable(df_current(),
options = list(orderClasses = TRUE,
lengthMenu = c(5, 10, 20), pageLength = 5))
})
shinyApp(ui=ui, server=server)
Instead of using a reactive/eventReactive statement for df, it might be more natural to keep track of previously inputted comments in the Comment column using a reactiveVal object for df. See also the responses to this question: R Shiny: reactiveValues vs reactive. If you prefer to use a reactive/eventReactive statement for df it is probably better to work with a separate object to store previous input comments (instead of incorporating it into the reactive statement for df).
library(shiny)
library(DT)
dat = data.frame(num=1:10, id=LETTERS[1:10], val=rnorm(10))
ui = fluidPage(
fluidRow(
column(12, selectInput('selectNum', label='Select Num',
choices=1:10)),
column(2, selectInput(inputId = 'selectID',
label = 'Select ID2',
choices = LETTERS[1:10],
selected='',
multiple=TRUE)),
column(6, textInput(inputId = 'comment',
label ='Please add comment in the text box:',
value = "", width = NULL,
placeholder = NULL)),
column(2, actionButton(inputId = "button",
label = "Add Comment"))
),
fluidRow (
column(12, DT::dataTableOutput('data') )
)
)
server <- function(input, output, session) {
## make df reactive
df_current <- reactiveVal(dat)
observeEvent(input$button, {
req(df_current(), input$selectID %in% dat$id)
## update df by adding comments
df_new <- df_current()
df_new[df_current()$id %in% input$selectID, "Comment"] <- input$comment
df_current(df_new)
})
output$data <- DT::renderDataTable({
req(df_current())
## filter df_current by 'selectNum'
df_filtered <- df_current()[df_current()$num %in% input$selectNum, ]
## show comments if non-empty
showComments <- is.null(df_filtered$Comment) || !all(is.na(df_filtered$Comment))
DT::datatable(df_filtered,
options = list(orderClasses = TRUE,
lengthMenu = c(5, 10, 20), pageLength = 5,
columnDefs = list(
list(targets = ncol(df_filtered), visible = showComments)
)
)
)
})
}
shinyApp(ui=ui, server=server)
Edit: below an edited server function that using df_current <- reactive({...}) instead of df_current <- reactiveVal({...}) and defining a separate reactiveVal object to keep track of the comments.
server <- function(input, output, session) {
## initialize separate reactive object for comments
df_comments <- reactiveVal({
data.frame(
id = character(0),
Comment = character(0),
stringsAsFactors = FALSE
)
})
## reactive object df
df_current <- reactive({
## reactivity that df depends on
## currently df = dat does not change
df <- dat
## merge with current comments
if(nrow(df_comments()) > 0)
df <- merge(df, df_comments(), by = "id", all.x = TRUE)
return(df)
})
observeEvent(input$button, {
req(input$selectID)
## update df_comments by adding comments
df_comments_new <- rbind(df_comments(),
data.frame(id = input$selectID, Comment = input$comment)
)
## if duplicated id's keep only most recent rows
df_comments_new <- df_comments_new[!duplicated(df_comments_new$id, fromLast = TRUE), , drop = FALSE]
df_comments(df_comments_new)
})
output$data <- DT::renderDataTable({
req(df_current())
## filter df_current by 'selectNum'
df_filtered <- df_current()[df_current()$num %in% input$selectNum, ]
## show comments if non-empty
showComments <- is.null(df_filtered$Comment) || !all(is.na(df_filtered$Comment))
DT::datatable(df_filtered,
options = list(orderClasses = TRUE,
lengthMenu = c(5, 10, 20), pageLength = 5,
columnDefs = list(
list(targets = ncol(df_filtered), visible = showComments)
)
)
)
})
}
There you have got a working example.
I think the thing is that you are trying to update a value through an observeEvent which is not good according to the documentation. ?observeEvent
Use observeEvent whenever you want to perform an action in response to an event. (Note that "recalculate a value" does not generally count as performing an action–see eventReactive for that.)
library(shiny)
library(DT)
dat = data.frame(num=1:10, id=LETTERS[1:10], val=rnorm(10))
ui = fluidPage(
fluidRow(
column(12, selectInput('selectNum', label='Select Num',
choices=1:10, selected='')),
column(2, selectInput(inputId = 'selectID',
label = 'Select ID2',
choices = LETTERS[1:10],
selected='',
multiple=TRUE)),
column(6, textInput(inputId = 'comment',
label ='Please add comment in the text box:',
value = "", width = NULL,
placeholder = NULL)),
column(2, actionButton(inputId = "button",
label = "Add Comment"))
),
fluidRow (
column(12, DT::dataTableOutput('data') )
)
)
server <- function(input, output, session) {
## make df reactive
df_current = reactive({
df = dat %>% filter(num %in% input$selectNum)
if(input$button != 0) {
input$button
df[df$id %in% input$selectID, "Comment"] <- isolate(input$comment)
}
return(df)
})
output$data <- DT::renderDataTable({
req(df_current())
DT::datatable(df_current(),
options = list(orderClasses = TRUE,
lengthMenu = c(5, 10, 20), pageLength = 5))
})
}
shinyApp(ui=ui, server=server)
So you can either go with your reactive value or using eventReactive as stated in the doc.

Output photos in shiny

Now I need to practice and build a recommender system by using R. Data set is from MovieLens. I want to output the movie photos as well, but not sure what to do. If there's 10000 movies, how should I save them and output them on my shiny APP? And suggestion is welcomed!
ui.R:
library(shiny)
library(shinydashboard)
library(proxy)
library(recommenderlab)
library(reshape2)
library(plyr)
library(dplyr)
library(DT)
library(RCurl)
setwd("C:\\Users\\lili\\Movieshiny")
movies <- read.csv("movies.csv", header = TRUE, stringsAsFactors=FALSE)
movies <- movies[with(movies, order(title)), ]
ratings <- read.csv("ratings100k.csv", header = TRUE)
shinyUI(dashboardPage(skin="blue",
dashboardHeader(title = "Movie Recommenders"),
dashboardSidebar(
sidebarMenu(
menuItem("Movies", tabName = "movies", icon = icon("star-o")),
menuItem("About", tabName = "about", icon = icon("question-circle")),
menuItem("Source code", icon = icon("file-code-o"),
href = "https://github.com/danmalter/Movielense"),
menuItem(
list(
selectInput("select", label = h5("Select 3 Movies That You Like"),
choices = as.character(movies$title[1:length(unique(movies$movieId))]),
selectize = FALSE,
selected = "Shawshank Redemption, The (1994)"),
selectInput("select2", label = NA,
choices = as.character(movies$title[1:length(unique(movies$movieId))]),
selectize = FALSE,
selected = "Forrest Gump (1994)"),
selectInput("select3", label = NA,
choices = as.character(movies$title[1:length(unique(movies$movieId))]),
selectize = FALSE,
selected = "Silence of the Lambs, The (1991)"),
submitButton("Submit")
)
)
)
),
dashboardBody(
tags$head(
tags$style(type="text/css", "select { max-width: 360px; }"),
tags$style(type="text/css", ".span4 { max-width: 360px; }"),
tags$style(type="text/css", ".well { max-width: 360px; }")
),
tabItems(
tabItem(tabName = "about",
h2("About this App"),
HTML('<br/>'),
fluidRow(
box(title = "Author: Danny Malter", background = "black", width=7, collapsible = TRUE,
helpText(p(strong("This application a movie reccomnder using the movielense dataset."))),
helpText(p("Please contact",
a(href ="https://twitter.com/danmalter", "Danny on twitter",target = "_blank"),
" or at my",
a(href ="http://danmalter.github.io/", "personal page", target = "_blank"),
", for more information, to suggest improvements or report errors.")),
helpText(p("All code and data is available at ",
a(href ="https://github.com/danmalter/", "my GitHub page",target = "_blank"),
"or click the 'source code' link on the sidebar on the left."
))
)
)
),
tabItem(tabName = "movies",
fluidRow(
box(
width = 6, status = "info", solidHead = TRUE,
title = "Other Movies You Might Like",
tableOutput("table")),
valueBoxOutput("tableRatings1"),
valueBoxOutput("tableRatings2"),
valueBoxOutput("tableRatings3"),
HTML('<br/>'),
box(DT::dataTableOutput("myTable"), title = "Table of All Movies", width=12, collapsible = TRUE)
)
)
)
)
)
)
server.R:
setwd("C:\\Users\\lili\\Movieshiny")
movies <- read.csv("movies.csv", header = TRUE, stringsAsFactors=FALSE)
movies <- movies[with(movies, order(title)), ]
ratings <- read.csv("ratings100k.csv", header = TRUE)
shinyServer(function(input, output) {
# Text for the 3 boxes showing average scores
formulaText1 <- reactive({
paste(input$select)
})
formulaText2 <- reactive({
paste(input$select2)
})
formulaText3 <- reactive({
paste(input$select3)
})
output$movie1 <- renderText({
formulaText1()
})
output$movie2 <- renderText({
formulaText2()
})
output$movie3 <- renderText({
formulaText3()
})
# Table containing recommendations
output$table <- renderTable({
# Filter for based on genre of selected movies to enhance recommendations
cat1 <- subset(movies, title==input$select)
cat2 <- subset(movies, title==input$select2)
cat3 <- subset(movies, title==input$select3)
# If genre contains 'Sci-Fi' then return sci-fi movies
# If genre contains 'Children' then return children movies
if (grepl("Sci-Fi", cat1$genres) | grepl("Sci-Fi", cat2$genres) | grepl("Sci-Fi", cat3$genres)) {
movies2 <- (movies[grepl("Sci-Fi", movies$genres) , ])
} else if (grepl("Children", cat1$genres) | grepl("Children", cat2$genres) | grepl("Children", cat3$genres)) {
movies2 <- movies[grepl("Children", movies$genres), ]
} else {
movies2 <- movies[grepl(cat1$genre1, movies$genres)
| grepl(cat2$genre1, movies$genres)
| grepl(cat3$genre1, movies$genres), ]
}
movie_recommendation <- function(input,input2,input3){
row_num <- which(movies2[,3] == input)
row_num2 <- which(movies2[,3] == input2)
row_num3 <- which(movies2[,3] == input3)
userSelect <- matrix(NA,length(unique(ratings$movieId)))
userSelect[row_num] <- 5 #hard code first selection to rating 5
userSelect[row_num2] <- 4 #hard code second selection to rating 4
userSelect[row_num3] <- 4 #hard code third selection to rating 4
userSelect <- t(userSelect)
ratingmat <- dcast(ratings, userId~movieId, value.var = "rating", na.rm=FALSE)
ratingmat <- ratingmat[,-1]
colnames(userSelect) <- colnames(ratingmat)
ratingmat2 <- rbind(userSelect,ratingmat)
ratingmat2 <- as.matrix(ratingmat2)
#Convert rating matrix into a sparse matrix
ratingmat2 <- as(ratingmat2, "realRatingMatrix")
#Create Recommender Model
recommender_model <- Recommender(ratingmat2, method = "UBCF",param=list(method="Cosine",nn=30))
recom <- predict(recommender_model, ratingmat2[1], n=30)
recom_list <- as(recom, "list")
recom_result <- data.frame(matrix(NA,30))
recom_result[1:30,1] <- movies2[as.integer(recom_list[[1]][1:30]),3]
recom_result <- data.frame(na.omit(recom_result[order(order(recom_result)),]))
recom_result <- data.frame(recom_result[1:10,])
colnames(recom_result) <- "User-Based Collaborative Filtering Recommended Titles"
return(recom_result)
}
movie_recommendation(input$select, input$select2, input$select3)
})
movie.ratings <- merge(ratings, movies)
output$tableRatings1 <- renderValueBox({
movie.avg1 <- summarise(subset(movie.ratings, title==input$select),
Average_Rating1 = mean(rating, na.rm = TRUE))
valueBox(
value = format(movie.avg1, digits = 3),
subtitle = input$select,
icon = if (movie.avg1 >= 3) icon("thumbs-up") else icon("thumbs-down"),
color = if (movie.avg1 >= 3) "aqua" else "red"
)
})
movie.ratings <- merge(ratings, movies)
output$tableRatings2 <- renderValueBox({
movie.avg2 <- summarise(subset(movie.ratings, title==input$select2),
Average_Rating = mean(rating, na.rm = TRUE))
valueBox(
value = format(movie.avg2, digits = 3),
subtitle = input$select2,
icon = if (movie.avg2 >= 3) icon("thumbs-up") else icon("thumbs-down"),
color = if (movie.avg2 >= 3) "aqua" else "red"
)
})
movie.ratings <- merge(ratings, movies)
output$tableRatings3 <- renderValueBox({
movie.avg3 <- summarise(subset(movie.ratings, title==input$select3),
Average_Rating = mean(rating, na.rm = TRUE))
valueBox(
value = format(movie.avg3, digits = 3),
subtitle = input$select3,
icon = if (movie.avg3 >= 3) icon("thumbs-up") else icon("thumbs-down"),
color = if (movie.avg3 >= 3) "aqua" else "red"
)
})
# Generate a table summarizing each players stats
output$myTable <- renderDataTable({
movies[c("title", "genres")]
})
}
)
For example, I want to insert this into my code:
library(shiny)
Define UI with external image call
ui <- fluidPage(
titlePanel("Look at the image below"),
sidebarLayout(sidebarPanel(),
mainPanel(htmlOutput("picture"))))
Define server with information needed to hotlink image
server <- function(input, output) {
output$picture <-
renderText({
c(
'<img src="',
"http://www.google.com.tw/search?biw=1536&bih=759&tbm=isch&sa=1&q=notebook+movie&oq=notebook+movie&gs_l=psy-ab.3..0l4.5729.7315.0.7708.6.6.0.0.0.0.223.623.4j1j1.6.0....0...1.1.64.psy-ab..0.6.622...0i67k1.0.P-BZX3u-bzo#imgrc=S0E91gxvZcgeMM:",
'">'
)
})
}
shinyApp(ui = ui, server = server)
Every movie has different poster images.

Shiny R: Modifying the variable class

I am trying to create a shiny-app that load data-set, present the variable list and their classes and allow the user to modify the class of a selected variable. All the functions in the following code are working except to the last function in the server- observeEvent which not working when trying to modify the variable class. Any suggestions?
Thank you in advance,
Rami
`
rm(list = ls())
library(shiny)
library(shinydashboard)
library(DT)
ui <- dashboardPage(
dashboardHeader(title = "Shiny Example"),
#--------------------------------------------------------------------
dashboardSidebar(
sidebarMenu(
menuItem("Data", tabName = "data", icon = icon("th"))
)
),
#--------------------------------------------------------------------
dashboardBody(
#--------------------------------------------------------------------
tabItem(tabName = "data",
fluidPage(
fluidRow(
box(
selectInput('dataset', 'Select Dataset', list(GermanCredit = "GermanCredit",
cars = "cars",
iris = "iris")),
title = "Datasets",width = 4, status = "primary",
checkboxInput("select_all", "Select All Variable", value = TRUE),
conditionalPanel(condition = "input.select_all == false",
uiOutput("show.var"))
),
box(
title = "Variable Summary", width = 4, status = "primary",
DT::dataTableOutput('summary.data')
),
box(
title = "Modify the Variable Class", width = 4, status = "primary",
radioButtons("choose_class", label = "Modify the Variable Class",
choices = list(Numeric = "numeric", Factor = "factor",
Character = "character"),
selected = "numeric"),
actionButton("var_modify", "Modify")
)
)
)
)
)
)
#--------------------------------------------------------------------
# Server Function
#--------------------------------------------------------------------
server <- function(input, output,session) {
#--------------------------------------------------------------------
# loading the data
get.df <- reactive({
if(input$dataset == "GermanCredit"){
data("GermanCredit")
GermanCredit
}else if(input$dataset == "cars"){
data(cars)
cars
}else if(input$dataset == "iris"){
data("iris")
iris
}
})
# Getting the list of variable from the loaded dataset
var_list <- reactive(names(get.df()))
# Choosing the variable - checkbox option
output$show.var <- renderUI({
checkboxGroupInput('show_var', 'Select Variables', var_list(), selected = var_list())
})
# Setting the data frame based on the variable selction
df <- reactive({
if(input$select_all){
df <- get.df()
} else if(!input$select_all){
df <- get.df()[, input$show_var, drop = FALSE]
}
return(df)
})
# create list of variables
col.name <- reactive({
d <- data.frame(names(df()), sapply(df(),class))
names(d) <- c("Name", "Class")
return(d)
})
# render the variable list into table
output$summary.data <- DT::renderDataTable(col.name(), server = FALSE, rownames = FALSE,
selection = list(selected = 1, mode = 'single'),
options = list(lengthMenu = c(5, 10, 15, 20), pageLength = 20, dom = 'p'))
# storing the selected variable from the variables list table
table.sel <- reactive({
df()[,which(colnames(df()) == col.name()[input$summary.data_rows_selected,1])]
})
# Trying to modify the variable class
observeEvent(input$var_modify,{
modify.row <- which(colnames(df()) == col.name()[input$summary.data_rows_selected,1])
if( input$choose_class == "numeric"){
df()[, modify.row] <- as.numeric(df()[, modify.row])
} else if( input$choose_class == "factor"){
df()[, modify.row] <- as.factor(df()[, modify.row])
} else if( input$choose_class == "character"){
df()[, modify.row] <- as.character(df()[, modify.row])
}
})
}
shinyApp(ui = ui, server = server)
`
I would use reactiveValues() instead.
library(shiny)
# Define UI for application that draws a histogram
ui <- shinyUI(fluidPage(
sidebarLayout(
sidebarPanel(
selectInput("classType", "Class Type:", c("as.numeric", "as.character"))
),
mainPanel(
textOutput("class")
)
)
))
server <- shinyServer(function(input, output) {
global <- reactiveValues(sample = 1:9)
observe({
global$sample <- get(input$classType)(global$sample)
})
output$class <- renderText({
print(class(global$sample))
})
})
shinyApp(ui = ui, server = server)
In case you are interested:
Concerning your attempt: reactive() is a function and you called the output of the function by df()[, modify.row]. So in your code you try to change the output of the function, but that does not change the output of futures calls of that function.
Maybe it is easier to see in a simplified version:
mean(1:3) <- 1
The code can not change the mean function to output 1 in future. So thats what reactiveValues() help with :). Hope that helps!

ShinyApp errors: selectInput, data-subsetting

I am creating shiny app. My goal is to visualize some data slices depending on the input.I am quite happy with the result.
However, my app has a few bugs while the app is loading. Before ploting the graph and visualizing inputs it shows some errors on screen (you can lauch the app and see the problem).
I believe, the first problem is with data filtering. I can't figure out how to deal with it and what is the problem. May I need to use other method or maybe other package? (see the output$Brand).
Error in grep(pattern, levels(vector)) : invalid 'pattern' argument
The second error comes when I am creating selectInput. I'd like to visualize all the brands of the specific category in one plot and to have an option to filter data by brand. However, my method is not working well. Any suggestions? (see the output$Brand).
Error in if (input$Brand == "All") { : argument is of length zero
Also, I enclose the code, which you can generate.
May you have any more suggestions how to simplify the code?
Thanks for the help!
library(shiny)
library(shinydashboard)
library(data.table)
library(ggplot2)
library(grid)
library(scales)
library(ggthemes)
# Header -----------------------------------------------------------
header <- dashboardHeader(title="Dashboard")
# Sidebar --------------------------------------------------------------
sm <- sidebarMenu(
menuItem(
text="Graph1",
tabName="Graph1",
icon=icon("home")
)
)
sidebar <- dashboardSidebar(sm)
# Body --------------------------------------------------
body <- dashboardBody(
# Layout --------------------------------------------
tabItems(
tabItem(
tabName="Graph1",
fluidPage(
fluidRow(
box(
title = "Inputs", status = "warning", width = 2, solidHeader = TRUE,
uiOutput("Year"),
uiOutput("Category"),
uiOutput("Brand"),
sliderInput("Finalas.Range", "Months:",
min = 1, max = 12, value = c(1,12))
),
box(
title = "Season", width = 10, status = "info", solidHeader = TRUE,
plotOutput("Graph1")
)
)
)
)
)
)
# Setup Shiny app UI components -------------------------------------------
ui <- dashboardPage(header, sidebar, body, skin="black")
# Setup Shiny app back-end components -------------------------------------
server <- function(input, output) {
# Generate data --------------------------------------
set.seed(1992)
n=99
Year <- sample(2013:2015, n, replace = TRUE, prob = NULL)
Month <- sample(1:12, n, replace = TRUE, prob = NULL)
Category <- sample(c("Car", "Bus", "Bike"), n, replace = TRUE, prob = NULL)
Brand <- sample("Brand", n, replace = TRUE, prob = NULL)
Brand <- paste0(Brand, sample(1:14, n, replace = TRUE, prob = NULL))
USD <- abs(rnorm(n))*100
df <- data.frame(Year, Month, Category, Brand, USD)
# Inputs --------------------------------------
output$Year <- renderUI({
selectInput("Year",
"Year:",
c(unique(as.character(df$Year))), selected = "2015")
})
output$Category <- renderUI({
selectInput("Category", "Choose category:",
choices = c("Car","Bus", "Bike" ))
})
output$Brand <- renderUI({
df2 <- (data.table(df))[like(df$Category,input$Category)]
selectInput("Brand",
"Brand:",
c("All", unique(as.character(df2$Brand))))
})
# Plot --------------------------------
output$Graph1 <- renderPlot({
df <- data.table(df)
if (input$Brand == "All") {
df <- df[like(df$Year, input$Year)]
df <- df[like(df$Category,input$Category)]
ggplot(df, aes(x=factor(Month,levels=1:12), y=USD, fill=Brand))+
geom_bar(stat='identity')+
scale_x_discrete('Month', breaks=factor(1:12), drop=FALSE)+
scale_fill_gdocs(guide = guide_legend(title = "Brand"))
} else {
df <- df[like(df$Year, input$Year)]
df <- df[like(df$Category,input$Category)]
df <- df[which(df$Brand == input$Brand),]
validate(
need(sum(df$USD)>0, paste(input$Brand, "was inactive in Year:",input$Year))
)
ggplot(df, aes(x=factor(Month,levels=1:12), y=USD, fill=Brand))+
geom_bar(stat='identity')+
scale_x_discrete('Month', breaks=factor(1:12), drop=FALSE)
}
})
# -----------------------------------------------------------------------------
}
# Render Shiny app --------------------------------------------------------
shinyApp(ui, server)
The following should eliminate these errors: for #1 the function like in datatable gives out the error so I changed it to %in% instead. and for #2 you have a null as a default so take care of that with an if statement
rm(list = ls())
library(shiny)
library(shinydashboard)
library(data.table)
library(ggplot2)
library(grid)
library(scales)
library(ggthemes)
# Header -----------------------------------------------------------
header <- dashboardHeader(title="Dashboard")
# Sidebar --------------------------------------------------------------
sm <- sidebarMenu(
menuItem(
text="Graph1",
tabName="Graph1",
icon=icon("home")
)
)
sidebar <- dashboardSidebar(sm)
# Body --------------------------------------------------
body <- dashboardBody(
# Layout --------------------------------------------
tabItems(
tabItem(
tabName="Graph1",
fluidPage(
fluidRow(
box(
title = "Inputs", status = "warning", width = 2, solidHeader = TRUE,
uiOutput("Year"),
uiOutput("Category"),
uiOutput("Brand"),
sliderInput("Finalas.Range", "Months:",
min = 1, max = 12, value = c(1,12))
),
box(
title = "Season", width = 10, status = "info", solidHeader = TRUE,
plotOutput("Graph1")
)
)
)
)
)
)
# Setup Shiny app UI components -------------------------------------------
ui <- dashboardPage(header, sidebar, body, skin="black")
# Setup Shiny app back-end components -------------------------------------
server <- function(input, output) {
# Generate data --------------------------------------
set.seed(1992)
n=99
Year <- sample(2013:2015, n, replace = TRUE, prob = NULL)
Month <- sample(1:12, n, replace = TRUE, prob = NULL)
Category <- sample(c("Car", "Bus", "Bike"), n, replace = TRUE, prob = NULL)
Brand <- sample("Brand", n, replace = TRUE, prob = NULL)
Brand <- paste0(Brand, sample(1:14, n, replace = TRUE, prob = NULL))
USD <- abs(rnorm(n))*100
df <- data.frame(Year, Month, Category, Brand, USD)
# Inputs --------------------------------------
output$Year <- renderUI({
selectInput("Year",
"Year:",
c(unique(as.character(df$Year))), selected = "2015")
})
output$Category <- renderUI({
selectInput("Category", "Choose category:",
choices = c("Car","Bus", "Bike" ))
})
output$Brand <- renderUI({
# first error
#df2 <- (data.table(df))[like(df$Category,input$Category)]
df2 <- df[df$Category %in% input$Category,]
selectInput("Brand",
"Brand:",
c("All", unique(as.character(df2$Brand))))
})
# Plot --------------------------------
output$Graph1 <- renderPlot({
df <- data.table(df)
if(is.null(input$Brand) || is.na(input$Brand)){return()}
else if (input$Brand == "All") {
df <- df[like(df$Year, input$Year)]
df <- df[like(df$Category,input$Category)]
ggplot(df, aes(x=factor(Month,levels=1:12), y=USD, fill=Brand))+
geom_bar(stat='identity')+
scale_x_discrete('Month', breaks=factor(1:12), drop=FALSE)+
scale_fill_gdocs(guide = guide_legend(title = "Brand"))
} else {
df <- df[like(df$Year, input$Year)]
df <- df[like(df$Category,input$Category)]
df <- df[which(df$Brand == input$Brand),]
validate(
need(sum(df$USD)>0, paste(input$Brand, "was inactive in Year:",input$Year))
)
ggplot(df, aes(x=factor(Month,levels=1:12), y=USD, fill=Brand))+
geom_bar(stat='identity')+
scale_x_discrete('Month', breaks=factor(1:12), drop=FALSE)
}
})
# -----------------------------------------------------------------------------
}
# Render Shiny app --------------------------------------------------------
shinyApp(ui, server)

Resources