elements in ui not reactive - r

I am trying to make reactive elements in my shiny app using RStudio. I want the radio buttons to appear or disappear depending upon a checkbox. Then I am gathering the inputs from the elements displayed to generate two graphs. The problem is that the elements in UI are not reactive. Below is the coding I used.
library(shiny)
library(AER)
library(ggplot2)
library(plotly)
CreditCard <- read.csv("https://gist.githubusercontent.com/anonymous/3ffc253260bae6894c00edb2062729d6/raw/6c08d02eaba4b1691212fd518f2079ef2c112a20/Credit_Card.csv")
key <- read.csv("https://gist.githubusercontent.com/anonymous/9a8c05eb2202d79b03b187117e6fe709/raw/beddca49b669fe5ff27ce7dd1c7bcbe1c4660327/key.csv")
df_cc = CreditCard[sample(nrow(CreditCard), 500), ]
ui <- fluidPage(
title = "Final Project",
sidebarLayout(
sidebarPanel(
conditionalPanel(
'input.tabs === "Graphs"',
checkboxInput("checkbox_facet", label = "Show Facet", value = TRUE),
tags$div(id = 'placeholder'),
selectInput("select_y", label = h4("Select Y-Axis"),
choices = list("Age" = "age", "Income" = "income", "Share" = "share", "Expenditure" = "expenditure", "Months" = "months", "MajorCards" = "majorcards", "Active" = "active"), selected = "active"),
selectInput("select_x", label = h4("Select X-Axis"),
choices = list("Age" = "age", "Income" = "income", "Share" = "share", "Expenditure" = "expenditure", "Months" = "months", "MajorCards" = "majorcards", "Active" = "active"), selected = "income")
) # end conditionalPanel for graphs
), #end sidebarPanel
mainPanel(
tabsetPanel(
id = 'tabs',
tabPanel("Graphs",
plotlyOutput(outputId = "exp"),
plotlyOutput(outputId = "reg"),
uiOutput(outputId = "facet")
) #Graphs
) # end tabsetPanel
) # end mainPanel
) # end sidebarLayout
) # end fluid page
server <- function(input, output) {
observeEvent(input$checkbox_facet, { if (input$checkbox_facet == TRUE) { # radio buttons for facet options show, and graph be made accordingly.
output$facet <- eventReactive(input$checkbox_facet, { insertUI( selector = "#placeholder",
ui = radioButtons("radio_facet", label = h4("Choose Facet Variable"),
choices = list("Card" = "card", "Reports" = "reports", "Owner" = "owner", "SelfEmployed" = "selfemp", "Dependents" = "dependents"), selected = "owner")
) })
output$exp <- eventReactive(input$select_x, { renderPlotly({
ggplotly(
ggplot(df_cc, aes(x=get(input$select_x), y=get(input$select_y))) + geom_point(shape=1) +
facet_wrap(~get(input$radio_facet), labeller = label_both) +
labs(title = "Exploratory Plot", x = input$select_x, y = input$select_y)
)
})
})
output$reg <- eventReactive(input$select_x, { renderPlotly({
ggplotly(
ggplot(df_cc, aes(x=get(input$select_x), y=get(input$select_y))) + geom_point(shape=1) +
geom_smooth(method = "glm", family = "poisson", se = FALSE) +
facet_wrap(~get(input$radio_facet), labeller = label_both) +
labs(title = "Poisson Regression", x = input$select_x, y = input$select_y)
)
})
})
}
else { # radio buttons disappear and graph is without facets
output$facet <- eventReactive(input$checkbox_facet, { removeUI(selector = 'div:has(> #radio_facet)', immediate = TRUE) })
output$exp <- eventReactive(input$select_x, { renderPlotly({
ggplotly(
ggplot(df_cc, aes(x=get(input$select_x), y=get(input$select_y))) + geom_point(shape=1) +
labs(title = "Exploratory Plot", x = input$select_x, y = input$select_y)
)
})
})
output$reg <- eventReactive(input$select_x, { renderPlotly({
ggplotly(
ggplot(df_cc, aes(x=get(input$select_x), y=get(input$select_y))) + geom_point(shape=1) +
geom_smooth(method = "glm", family = "poisson", se = FALSE) +
labs(title = "Poisson Regression", x = input$select_x, y = input$select_y)
)
})
})
}
}) # end observeEvent for graphs
}
shinyApp(ui, server)

You're just overcomplicating things.
In your code, you have reactive expressions, that reactively assign other reactive expressions. So you always fight with a double layer of reactivity.
I don't know if you noticed, but you also delete the placeholder div the first time the checkbox is unchecked. You maybe did this on purpose, because otherwise the radio buttons will always be there. Because overwriting the output$facet will not delete any reacting expressions. And your reactive logic itself does not contain the state of input$checkbox_facet. So you are always fighting with reactive expressions, that you reassign and where you have no control over how they are executed.
What I recommend is, to clean up your code. Pick each output element by itself and define what reactions you really want to happen. And then define a fixed behaviour, that reflects that.
Also, be aware that render functions are reactive environments by default.
Below is a refactoring that works:
library(shiny)
library(AER)
library(ggplot2)
library(plotly)
CreditCard <- read.csv("https://gist.githubusercontent.com/anonymous/3ffc253260bae6894c00edb2062729d6/raw/6c08d02eaba4b1691212fd518f2079ef2c112a20/Credit_Card.csv")
key <- read.csv("https://gist.githubusercontent.com/anonymous/9a8c05eb2202d79b03b187117e6fe709/raw/beddca49b669fe5ff27ce7dd1c7bcbe1c4660327/key.csv")
df_cc = CreditCard[sample(nrow(CreditCard), 500), ]
ui <- fluidPage(
title = "Final Project",
sidebarLayout(
sidebarPanel(
conditionalPanel(
'input.tabs === "Graphs"',
checkboxInput("checkbox_facet", label = "Show Facet", value = TRUE),
uiOutput("facets"),
selectInput("select_y", label = h4("Select Y-Axis"),
choices = list("Age" = "age", "Income" = "income", "Share" = "share", "Expenditure" = "expenditure", "Months" = "months", "MajorCards" = "majorcards", "Active" = "active"), selected = "active"),
selectInput("select_x", label = h4("Select X-Axis"),
choices = list("Age" = "age", "Income" = "income", "Share" = "share", "Expenditure" = "expenditure", "Months" = "months", "MajorCards" = "majorcards", "Active" = "active"), selected = "income")
) # end conditionalPanel for graphs
), #end sidebarPanel
mainPanel(
tabsetPanel(
id = 'tabs',
tabPanel("Graphs",
plotlyOutput(outputId = "exp"),
plotlyOutput(outputId = "reg")
) #Graphs
) # end tabsetPanel
) # end mainPanel
) # end sidebarLayout
) # end fluid page
server <- function(input, output) {
output$facets <- renderUI({
if (input$checkbox_facet) {
radioButtons("radio_facet",
label = h4("Choose Facet Variable"),
choices = list("Card" = "card", "Reports" = "reports", "Owner" = "owner", "SelfEmployed" = "selfemp", "Dependents" = "dependents"),
selected = "owner"
)
}
})
output$exp <- renderPlotly({
g <- ggplot(df_cc, aes(x=get(input$select_x), y=get(input$select_y))) +
geom_point(shape=1) +
labs(title = "Exploratory Plot", x = input$select_x, y = input$select_y)
if (input$checkbox_facet) {
g <- g + facet_wrap(~get(input$radio_facet), labeller = label_both)
}
ggplotly(g)
})
output$reg <- renderPlotly({
g <- ggplot(df_cc, aes(x=get(input$select_x), y=get(input$select_y))) +
geom_point(shape=1) +
geom_smooth(method = "glm", family = "poisson", se = FALSE) +
labs(title = "Poisson Regression", x = input$select_x, y = input$select_y)
if (input$checkbox_facet) {
g <- g + facet_wrap(~get(input$radio_facet), labeller = label_both)
}
ggplotly(g)
})
}
shinyApp(ui, server)
To address the comment from Gregor de Cillia about conditional panels: You might not want to recreate the radio buttons every time the checkbox changes, since the options are in fact always the same. (And you might want to keep the state, i.e. which item was selected previously.) A conditionalPanel just hides the radio buttons and therefore cleans up your server code even more.
Example below:
library(shiny)
library(AER)
library(ggplot2)
library(plotly)
CreditCard <- read.csv("https://gist.githubusercontent.com/anonymous/3ffc253260bae6894c00edb2062729d6/raw/6c08d02eaba4b1691212fd518f2079ef2c112a20/Credit_Card.csv")
key <- read.csv("https://gist.githubusercontent.com/anonymous/9a8c05eb2202d79b03b187117e6fe709/raw/beddca49b669fe5ff27ce7dd1c7bcbe1c4660327/key.csv")
df_cc = CreditCard[sample(nrow(CreditCard), 500), ]
ui <- fluidPage(
title = "Final Project",
sidebarLayout(
sidebarPanel(
conditionalPanel(
'input.tabs === "Graphs"',
checkboxInput("checkbox_facet", label = "Show Facet", value = TRUE),
conditionalPanel('input.checkbox_facet',
radioButtons("radio_facet",
label = h4("Choose Facet Variable"),
choices = list("Card" = "card", "Reports" = "reports", "Owner" = "owner", "SelfEmployed" = "selfemp", "Dependents" = "dependents"),
selected = "owner"
)
),
selectInput("select_y", label = h4("Select Y-Axis"),
choices = list("Age" = "age", "Income" = "income", "Share" = "share", "Expenditure" = "expenditure", "Months" = "months", "MajorCards" = "majorcards", "Active" = "active"), selected = "active"),
selectInput("select_x", label = h4("Select X-Axis"),
choices = list("Age" = "age", "Income" = "income", "Share" = "share", "Expenditure" = "expenditure", "Months" = "months", "MajorCards" = "majorcards", "Active" = "active"), selected = "income")
) # end conditionalPanel for graphs
), #end sidebarPanel
mainPanel(
tabsetPanel(
id = 'tabs',
tabPanel("Graphs",
plotlyOutput(outputId = "exp"),
plotlyOutput(outputId = "reg")
) #Graphs
) # end tabsetPanel
) # end mainPanel
) # end sidebarLayout
) # end fluid page
server <- function(input, output) {
output$exp <- renderPlotly({
g <- ggplot(df_cc, aes(x=get(input$select_x), y=get(input$select_y))) +
geom_point(shape=1) +
labs(title = "Exploratory Plot", x = input$select_x, y = input$select_y)
if (input$checkbox_facet) {
g <- g + facet_wrap(~get(input$radio_facet), labeller = label_both)
}
ggplotly(g)
})
output$reg <- renderPlotly({
g <- ggplot(df_cc, aes(x=get(input$select_x), y=get(input$select_y))) +
geom_point(shape=1) +
geom_smooth(method = "glm", family = "poisson", se = FALSE) +
labs(title = "Poisson Regression", x = input$select_x, y = input$select_y)
if (input$checkbox_facet) {
g <- g + facet_wrap(~get(input$radio_facet), labeller = label_both)
}
ggplotly(g)
})
}
shinyApp(ui, server)

Related

How do I add the option to connect observations by ID in Shiny?

I'm working on my Shiny app that visualizes/summarizes PK data. Anyways, I have a small question. I want to add in the option for the user to connect observations by ID in Shiny, so I want them to choose. This could be a single tickbox which would be: "Connect observations by ID', or just a statement like: 'Connect observations by ID:" with boxes as 'Yes' or 'No'. I hope you get what I mean. How do I do this? I have a pretty large code for my app, as I've come a long way already.
Small note, I can't generate a report yet, as the code is not right, but you can just ignore this. Tab 2 is not finished yet, but the base is there.
UI
ui <- fluidPage(
tabsetPanel(tabPanel("Tab 1",
titlePanel("Shiny App: Concentration vs Time Graphs"),
sidebarLayout(
mainPanel("Concentration vs Time graphs", plotOutput(outputId = "plot")),
sidebarPanel(style = "height:90vh; overflow-y: auto",
p("This app is developed to visualize pharmacokinetic data of different antibodies. Please select the data you want to visualize before running the graph. The graph can be reset with the reset button."),
strong("1. Filter your data for these following variables:"),
checkboxInput('checkbox1', 'Filter by study', FALSE),
conditionalPanel(condition = "input.checkbox1 == 1",
selectInput(inputId = "study", label = "Include study:",
choices = c("GLP Toxicity" = "GLPTOX", "Dose Range Finding" = "DRF", "Single Dose" = "SD", "Repeat Dose" = "RD"),
selected = c("GLPTOX", "DRF", "SD", "RD"),
multiple = T)
),
checkboxInput('checkbox2', 'Filter by platform', FALSE),
conditionalPanel(condition = "input.checkbox2 == 1",
selectInput(inputId = "platform", label = "Include platform:",
choices = c("Hexabody", 'Duobody' = "Doubody", "Bispecific"), selected = c("Hexabody", "Doubody", "Bispecific"),
multiple = T)
),
checkboxInput('checkbox3', 'Filter by species', F),
conditionalPanel(condition = "input.checkbox3 == 1",
selectInput(inputId = "species", label = "Include species:",
choices = c("Monkey", 'Mouse'), selected = c('Monkey', 'Mouse'), multiple = T)
),
checkboxInput('checkbox4', 'Filter by administration route', F),
conditionalPanel(condition = "input.checkbox4 == 1",
selectInput(inputId = "route", label = "Include administration route:",
choices = c('Route 1' = "ROUTE1", 'Route 2' = "ROUTE2"), selected = c("ROUTE1", "ROUTE2"),
multiple = T)
),
selectInput(inputId = "x", label = "2. X-axis:", choices = c("Time" = "TIME", "TLD"), selected = "Time"
),
selectInput(inputId = 'column', label = "3. Columns for:",
choices = c("Dose mg/kg" = "DOSEMGKG", "Species" = "SPECIES", "Antibody" = "ABXID", "Subspecies" = "SUBSPECIES", "Age" = "AGE", "Animal ID" = "ANIMALID"),
selected = "DOSEMGKG"
),
conditionalPanel(condition = "input.column == 'DOSEMGKG'",
selectInput(inputId = 'dose', label = "Choose dose(s):",
choices = c("0.05", '0.5', "20", '5'), selected = c('0.05', '0.5', '20', '5'), multiple = T
)
),
selectInput(inputId = 'row', label = "4. Rows for:",
choices = c("Dose mg/kg" = "DOSEMGKG", "Species" = "SPECIES", "Antibody" = "ABXID", "Subspecies" = "SUBSPECIES", "Age" = "AGE", "Animal ID" = "ANIMALID",
"Platform" = "PLATFORM", "Mutation" = "MUTATION"),
selected = "ABXID"
),
conditionalPanel(condition = "input.row == 'MUTATION'",
selectInput(inputId = 'mutation', label = "Choose mutation(s):", choices = c('M1', "M2", "M3"), selected = c('M1', "M2", "M3"), multiple = T
)
),
conditionalPanel(
condition = "input.row == 'ABXID'",
selectInput(
inputId = 'antibody',
label = "Choose antibody(s):",
choices = c('Duobody-XXXXX', "Duobody-CD3x5T4"), selected = c('Duobody-XXXXX', 'Duobody-CD3x5T4'), multiple = T
)
),
selectInput(
inputId = "group",
label = "5. Group by:",
choices = c("Dose mg/kg" = "DOSEMGKG", "Species" = "SPECIES", "Antibody" = "ABXID", "Subspecies" = "SUBSPECIES", "Age" = "AGE", "Animal ID" = "ANIMALID",
'Administration route' = 'ROUTE'),
selected = "ANIMALID"
),
sliderInput(
inputId = 'trange',
label = "6. Time range:",
min = 0,
max = 1704,
value = c(0, 1704 )
),
actionButton(
inputId = 'runbutton',
label = 'Run graph'
),
actionButton(
inputId = 'resetbutton',
label = 'Reset graph'
),
downloadButton(outputId = 'report', label = "Generate report"),
br(),
br(),
br(),
p("----------")
))
)),
tabsetPanel(tabPanel("Tab 2",
titlePanel("Tab 2"),
sidebarLayout(
mainPanel("Plot #2", plotOutput(outputId = "plot2")),
sidebarPanel(helpText("Whatever text..."),
selectInput(
inputId = 't',
label = "Example",
choices = c("#1", "#2", "#3"),
selected = "#1"
)
)
)))
)
Server
server <- function(input, output, session){
observeEvent(input$runbutton, {output$plot <- renderPlot({
ggplot(data = df %>% filter(STUDYID %in% input$study & ABXID %in% input$antibody & MUTATION %in% input$mutation & PLATFORM %in% input$platform
& SPECIES %in% input$species & DOSEMGKG %in% input$dose & ROUTE %in% input$route),
aes_string(x = input$x, y = "DV", col = input$group)) + xlab("Time") + ylab("Concentration (ug/mL)") +
geom_point() + facet_grid(get(input$row) ~ get(input$column)) + scale_x_continuous(limits = input$trange) +
scale_color_viridis(discrete = T, option = 'F', begin = 0, end = 0.8) + theme_bw() + scale_y_log10()})})
observeEvent(input$resetbutton, {output$plot <- renderPlot({ NULL })})
output$report <- downloadHandler(filename = "report.pdf", content = function(file){
tempReport <- file.path(tempdir(), "report.Rmd")
file.copy("report.Rmd", tempReport, overwrite = T)
params <- list(n = input$x)
rmarkdown::render(tempReport, output_file = file, params = params, envir = new.env(parent = globalenv()))
})
}
shinyApp(ui = ui, server = server)
I know that it's something with geom_line(aes(group = "ANIMALID")), but I do not yet know how to make this an option to include/exclude.
Here is a simple app, that has a ggplot2 with some data, and whether the points are to be drawn connected by lines (within relevant groups) is toggleable.
I hope it helps you; your posted code is not reproducible as it uses private data, (and it is not minimal, its a lot of content to look at).
perhaps you can use this example as a base to ask further questions from as you complicate it, or account for relevant differences. but notice how my example is at least reproducible (you can run it; it is based on public, not private data).
library(shiny)
library(tidyverse)
some_data <- distinct(
iris,
Species, Petal.Width, Petal.Length
) |>
group_by(Species, Petal.Width) |>
summarise(avg_Petal.Length = mean(Petal.Length)) |>
ungroup()
ui <- fluidPage(
plotOutput("myplot", width = 400, height = 400),
checkboxInput("mytog", "line?")
)
server <- function(input, output, session) {
output$myplot <- renderPlot({
plot_to_show <-
ggplot(data = some_data) +
aes(
x = Petal.Width,
y = avg_Petal.Length,
colour = Species
) +
geom_point()
if (isTruthy(input$mytog)) {
plot_to_show <- plot_to_show + geom_line()
}
plot_to_show
})
}
shinyApp(ui, server)

Interactive plotting on RShiny

I am currently trying to make an interactive app on shiny where with my data frame "keep_df" you can choose which kind of plot you want to use and for the x and y axes you can choose any of the columns from keep_df. Below is my code. I'm not getting any error messages, but the code is not running as desired. I was wondering if anyone had any suggestions. Thanks!
ui <- navbarPage ("Title",
tabPanel("Chart builder",
sidebarLayout(
sidebarPanel(
pickerInput(inputId = 'chart', label = '1. Select chart type', choices = c("Scatter plot", "Bar chart", "Histogram", "Pie chart", "Box plot"), selected = NULL, multiple = FALSE),
pickerInput(inputId = 'xaxis', label = '2. Select X-axis', choices = colnames(keep_df), selected = NULL, multiple = FALSE),
pickerInput(inputId = 'yaxis', label = '3. Select Y-axis', choices = colnames(keep_df), selected = NULL, multiple = FALSE),
uiOutput("picker2"),
actionButton("view", "View selection"),
),
mainPanel(ui <- DT::dataTableOutput("charttable"), plotOutput("plots")),
)
)
)
server <- function(input, output, session) {
data <- reactive(
keep_df
)
plots <- reactive({
if (input$chart == 'Scatter plot') {
ggplot(data(), aes(x = input$xaxis, y = input$yaxis)) +
geom_point(colour = "black")
}
if (input$chart == 'Bar chart') {
ggplot(data(), aes(x = input$xaxis, y = input$yaxis)) +
geom_point(colour = "black")
}
})
output$plots <- renderPlot(
plots()
)
}
You were pretty close with your code, I noticed a few issues. First, you have an extra ui <- which I could see causing an error. Second, in the plots reactive, where you had x = input$xaxis, it would send a string to the ggplot, rather than a variable. Meaning it wouldn't read the column. I also made the plots reactive as an if and else if, rather than two if statements. Hope this helps!
Note that I didn't have the dataframe, so I just used mtcars for simplicity. There were a few lines I blocked out too. I also added the library and the shinyApp call too, since it wasn't in your example.
library(shiny)
library(ggplot2)
library(shinyWidgets)
keep_df<-mtcars #Don't have the data, just using mtcars
ui <- navbarPage ("Title",
tabPanel("Chart builder",
sidebarLayout(
sidebarPanel(
pickerInput(inputId = 'chart', label = '1. Select chart type', choices = c("Scatter plot", "Bar chart", "Histogram", "Pie chart", "Box plot"), selected = NULL, multiple = FALSE),
pickerInput(inputId = 'xaxis', label = '2. Select X-axis', choices = colnames(keep_df), selected = NULL, multiple = FALSE),
pickerInput(inputId = 'yaxis', label = '3. Select Y-axis', choices = colnames(keep_df), selected = NULL, multiple = FALSE)#,
# uiOutput("picker2"), #Not doing anything
# actionButton("view", "View selection") #Not doing anything
),
mainPanel(DT::dataTableOutput("charttable"), plotOutput("plots")), #Removed the ui <-
)
)
)
server <- function(input, output, session) {
data <- reactive(
keep_df
)
plots <- reactive({
if (input$chart == 'Scatter plot') {
#without the eval(parse(text =)), it reads as string, not variable
ggplot(data(), aes(x = eval(parse(text = input$xaxis)), y = eval(parse(text = input$yaxis)))) +
geom_point(colour = "black")
} else if (input$chart == 'Bar chart') {
ggplot(data(), aes(x = eval(parse(text = input$xaxis)), y = eval(parse(text = input$yaxis)))) +
geom_boxplot(colour = "black")
}
})
output$plots <- renderPlot(
plots()
)
}
shinyApp(ui, server)

Shiny R: Can't display plot

I try to display interactive plots by using R shiny. I can successfully make the GUI and published, but the plots in tabPanel shows nothing, just like the picture shows below. There is the data I used (have been downloaded into my laptop).
I think problem may caused by the way how I preprocessing my data in server.R, but whatever I tried, it still display nothing. No Error shows when I run the app.
enter image description here
My code in ui.R:
library(shiny)
shinyUI(fluidPage(
titlePanel("Data Viz Lab"),
sidebarLayout(
sidebarPanel(
## Add X-Variable select element
selectInput(inputId = "var_x",
label = h5("X-Variable"),
choices = c("Structure.Cost", "Land.Value", "Home.Value", "Home.Price.index"),
selected = "Land.Value"),
## Add Fill Color select element
selectInput(inputId = "color",
label = h5("Fill Color"),
choices = c("brown", "yellow", "green", "blue", "red"),
selected = "brown"),
## Add log-scale check box
checkboxInput(inputId = "log",
label = "log-sclae for X-variable in Scatterplot?",
value = FALSE),
## Add Y-Variable select element
selectInput(inputId = "var_y",
label = h5("Y-Variable"),
choices = c("Structure.Cost", "Land.Value", "Home.Value", "Home.Price.index"),
selected = "Structure.Cost"),
## Add Circle-Size side bar
sliderInput(inputId = "size",
label = h5("Circle-Size"),
min = 1,
max = 10,
value = 3),
## Add Outlier color select element
selectInput(inputId = "color_out",
label = h5("Outlier Color"),
choices = c("white", "yellow", "green", "blue", "red"),
selected = "white")
),
mainPanel(
tabsetPanel( # Establish tabset panel
tabPanel(
# Tab1
title = "Histogram",
value = plotOutput(outputId = "hist") # Add an figure in tab1
),
tabPanel(
# Tab2
title = "Scatterplot",
value = plotOutput(outputId = "scatter") # Add an figure in tab2
)
)
)
)
))
My code in server.R:
library(shiny)
library(ggplot2)
library(sp)
library(dplyr)
# setwd()
landdata = read.csv("landdata.csv")
options(scipen = 999)
shinyServer(function(input, output) {
## Plotting Histogram
output$hist = renderPlot({
# Plotting
if (input$log == FALSE){
ggplot(landdata, aes_string(x = input$var_x)) +
geom_histogram(color = input$color)
}else{
ggplot(landdata, aes_string(x = input$var_x)) +
geom_histogram(color = input$color) +
scale_x_log10(input$var_x)
}
})
## Plotting Scatter plot
output$scatter = renderPlot({
# Data pre-processing
p = ggplot(data = landdata, aes_string(x = input$var_x, y = input$var_y)) +
geom_point() +
stat_ellipse(type = "norm", level = 0.95, color = "black")
build = ggplot_build(p)$data
pts = build[[1]]
elli = build[[2]]
Outlier = point.in.polygon(pts$x, pts$y, elli$x, elli$y)
landdata = cbind(landdata, Outlier)
landdata$Outlier = ifelse(landdata$Outlier == 0, yes = "Y", no = "N") %>% factor(level = c("Y", "N"))
# Plotting
if (input$log == FALSE){
ggplot(landdata, aes_string(x = input$var_x, y = input$var_y)) +
geom_point(aes(color = Outlier), size = input$size) +
scale_color_manual(values = c(input$color, input$color_out))
}else{
ggplot(landdata, aes_string(x = input$var_x, y = input$var_y)) +
geom_point(aes(color = Outlier), size = input$size) +
scale_color_manual(values = c(input$color, input$color_out)) +
scale_x_log10(input$var_x)
}
})
})
The mistake lies in the tabPanel setup. value is not the correct argument for the plot. value is "the value that should be sent when tabsetPanel reports that this tab is selected" (taken from the manual). That means, value has the role of an id (like id argument of tabsetPanel or outputId of plotOutput).
Remove value = to make it work (the code snippet below gave me an output on my system).
tabsetPanel( # Establish tabset panel
tabPanel(
# Tab1
title = "Histogram",
plotOutput(outputId = "hist") # Add an figure in tab1
),
tabPanel(
# Tab2
title = "Scatterplot",
plotOutput(outputId = "scatter") # Add an figure in tab2
)
)

Shiny app very slow and RegData error, what in code might be causing this?

I'm trying to run a dashboard on shiny and the end result is incredibly slow, I'm also getting an error when running so i suspect the app might have crashed? any idea what in the code might be causing this?
I just start to code the linear regression I'm not sure about the efficiently of the code.
The plots not appears on the dashboard.
Thank youu
# Define UI ----
ui <- fluidPage(
titlePanel("AirBnb NYC"),
sidebarLayout(
sidebarPanel(
fluidRow(
column(3,
selectInput("select", h3("Which Neighbourhood group ?"), choices =
c("Brooklyn","Manhattan","Queens","Staten Island", "Bronx"))),
column(3,
selectInput("select2", h3("which Neighbourhood ?"), choices = "")),
column(3,
selectInput("select1", h3("Room Type"), choices = ""))),
p("Select the inputs for the Dependent Variable"),
selectInput(inputId = "DepVar", label = "Dependent Variables", multiple = FALSE, choices =
colnames(AB_NYC_2019)),
p("Select the inputs for the Independent Variable"),
selectInput(inputId = "IndVar", label = "Independent Variables", multiple = FALSE,
choices = list( "price"))
),
mainPanel( leafletOutput("map",width = "100%",height = "800"),
fluidRow(column(width = 6, plotOutput("data")),
column(width = 6, plotOutput("plot"))),
verbatimTextOutput(outputId = "RegSum"),
verbatimTextOutput(outputId = "IndPrint"),
verbatimTextOutput(outputId = "DepPrint"))
))
Define server logic ----
server <- function(input, output, session) {
#Define parameters of search
observe({
print(input$select)
x <- AB_NYC_2019 %>% filter(neighbourhood_group == input$select) %>% select(neighbourhood)
updateSelectInput(session, "select2", "select your neighbourhood", choice = unique(x))
})
observe({
productdata <- AB_NYC_2019$room_type[AB_NYC_2019$neighbourhood == input$select2]
updateSelectInput(session, "select1", "Which room type?", choices = unique(productdata))
})
#Create map
color <- colorFactor(palette = c("red", "green", "blue", "purple", "yellow"),
AB_NYC_2019$neighbourhood_group)
filteredData <- reactive({filter(AB_NYC_2019, neighbourhood_group == input$select)})
output$map <- renderLeaflet({
map <- leaflet(filteredData()) %>% addProviderTiles(providers$Esri.WorldTopoMap) %>%
# setView(lng = -73.98928, lat = 40.75042, zoom = 10) %>%
addCircleMarkers(
lng=~longitude, # Longitude coordinates
lat=~latitude, # Latitude coordinates
stroke=TRUE, # Circle stroke
weight = 0.1,
radius = 0.5,
fillOpacity=0.5,
color=~color(neighbourhood_group),
label = paste("Name:", AB_NYC_2019$name, "<br>",
"Price:", AB_NYC_2019$price, "<br>",
"Reviews:", AB_NYC_2019$number_of_reviews, "<br>")) %>%
addLegend("bottomright", pal = color, values = ~neighbourhood_group,
title = "Neighbourhood groups",
opacity = 1
)
})
#filter map
observe({
leafletProxy("map", data = filteredData()) %>%
clearShapes() %>%
addMarkers(~longitude, ~latitude,
label = ~neighbourhood_group,
labelOptions = labelOptions(textsize = "12px"))
})
lm1 <- reactive({lm(reformulate(input$IndVar, input$DepVar), data = RegData)})
output$DepPrint <- renderPrint({input$DepVar})
output$IndPrint <- renderPrint({input$IndVar})
output$RegSum <- renderPrint({summary(lm1())})
#Get many plots
output$data <- renderPlot({
ggplot(AB_NYC_2019, aes(price)) +
geom_histogram(bins = 30, aes(y = ..density..), fill = "purple") +
geom_density(alpha = 0.2, fill = "purple") +
th +
ggtitle("Distribution of price",
subtitle = "The distribution is very skewed") +
theme(axis.title = element_text(), axis.title.x = element_text()) +
geom_vline(xintercept = round(mean(AB_NYC_2019$price), 2), size = 2, linetype = 3)
})
output$plot <- renderPlot({
AB_NYC_2019 %>% filter(price >= mean(price)) %>% group_by(neighbourhood_group, room_type) %>%
tally %>%
ggplot(aes(reorder(neighbourhood_group,desc(n)), n, fill = room_type)) +
th +
xlab(NULL) +
ylab("Number of objects") +
ggtitle("Number of above average price objects",
subtitle = "Most of them are entire homes or apartments") +
geom_bar(stat = "identity")
})
}
Run the app ----
shinyApp(ui = ui, server = server)
Try this
AB_NYC_2019 <- AB_NYC_2019[1:50,]
# Define UI ----
ui <- fluidPage(
titlePanel("AirBnb NYC"),
sidebarLayout(
sidebarPanel(
selectInput("select", h3("Which Neighbourhood group ?"), choices =
c("Brooklyn","Manhattan","Queens","Staten Island", "Bronx")),
selectInput("select2", h3("which Neighbourhood ?"), choices = ""),
selectInput("select1", h3("Room Type"), choices = ""),
p("Select the inputs for the Dependent Variable"),
selectInput(inputId = "DepVar", label = "Dependent Variables", multiple = FALSE, choices =
colnames(AB_NYC_2019)),
p("Select the inputs for the Independent Variable"),
selectInput(inputId = "IndVar", label = "Independent Variables", multiple = FALSE,
choices = list( "price"))
),
mainPanel( leafletOutput("map",width = "100%",height = "800"),
fluidRow(column(width = 6, plotOutput("data")),
column(width = 6, plotOutput("plot"))),
verbatimTextOutput(outputId = "RegSum"),
verbatimTextOutput(outputId = "IndPrint"),
verbatimTextOutput(outputId = "DepPrint"))
)
)
server <- function(input, output, session) {
#Define parameters of search
observe({
req(input$select)
x <- AB_NYC_2019 %>% dplyr::filter(neighbourhood_group == input$select) %>% select(neighbourhood)
updateSelectInput(session, "select2", "select your neighbourhood", choice = unique(x))
})
observe({
req(input$select2)
productdata <- AB_NYC_2019$room_type[AB_NYC_2019$neighbourhood == input$select2]
updateSelectInput(session, "select1", "Which room type?", choices = unique(productdata))
})
#Create map
color <- colorFactor(palette = c("red", "green", "blue", "purple", "yellow"),
unique(AB_NYC_2019$neighbourhood_group))
filteredData <- reactive({
req(input$select)
filter(AB_NYC_2019, neighbourhood_group == input$select)})
output$map <- renderLeaflet({
req(filteredData())
map <- leaflet(filteredData()) %>% addProviderTiles(providers$Esri.WorldTopoMap) %>%
setView(lng = -73.98928, lat = 40.75042, zoom = 10) %>%
addCircleMarkers(
lng=~longitude, # Longitude coordinates
lat=~latitude, # Latitude coordinates
stroke=TRUE, # Circle stroke
weight = 0.1,
radius = 0.5,
fillOpacity=0.5,
color=~color(neighbourhood_group),
label = paste("Name:", filteredData()$name,
"\nPrice:", filteredData()$price,
"\nReviews:", filteredData()$number_of_reviews)
) %>%
addLegend("bottomright", pal = color, values = ~neighbourhood_group,
title = "Neighbourhood groups",
opacity = 1
)
})
#filter map
observe({
req(filteredData())
labs <- lapply(seq(nrow(filteredData())), function(i) {
paste0( '<p> Name: ', filteredData()[i, "name"], '<p></p>', 'Price: ',
filteredData()[i, "price"],'</p><p>', 'Reviews: ',
filteredData()[i, "number_of_reviews"], '</p>' )
})
leafletProxy("map", data = filteredData()) %>%
clearShapes() %>%
addMarkers(~longitude, ~latitude,
label = lapply(labs, htmltools::HTML),
labelOptions = labelOptions(textsize = "12px"))
})
lm1 <- reactive({
req(filteredData())
lm(reformulate(input$IndVar, input$DepVar), data = filteredData())})
output$DepPrint <- renderPrint({input$DepVar})
output$IndPrint <- renderPrint({input$IndVar})
output$RegSum <- renderPrint({
req(lm1())
summary(lm1())})
#Get many plots
output$data <- renderPlot({
ggplot(AB_NYC_2019, aes(price)) +
geom_histogram(bins = 30, aes(y = ..density..), fill = "purple") +
geom_density(alpha = 0.2, fill = "purple") +
theme_bw() +
ggtitle("Distribution of price",
subtitle = "The distribution is very skewed") +
theme(axis.title = element_text(), axis.title.x = element_text()) +
geom_vline(xintercept = round(mean(AB_NYC_2019$price), 2), size = 2, linetype = 3)
})
output$plot <- renderPlot({
AB_NYC_2019 %>% filter(price >= mean(price)) %>% group_by(neighbourhood_group, room_type) %>%
tally %>%
ggplot(aes(reorder(neighbourhood_group,desc(n)), n, fill = room_type)) +
theme_bw() +
xlab(NULL) +
ylab("Number of objects") +
ggtitle("Number of above average price objects",
subtitle = "Most of them are entire homes or apartments") +
geom_bar(stat = "identity")
})
}
shinyApp(ui, server)

How to extract element name, not value, from a list in R Shiny selectInput()?

I would like to extract the element name, and not the specific value, from a list used for the choices argument in selectInput() from R Shiny.
The selectInput function looks like this:
# ...
selectInput("xvar", "What is the predictor variable?",
choices = list("MPG" = "mpg",
"Cylinders" = "cyl",
"Engine Displacement" = "disp",
"Horse Power" = "hp",
"Gears" = "gear"),
# ...
In my server.R code I would like to use, for example, "Cylinders" and not "cyl" as an axis label. For example (using ggplot2):
# ...
labs(x = input$xvar, y = input$yvar) +
# ...
names(input$xvar) returns NULL. Is there any way to call input$xvar and return the name?
Thanks to Paul's comments, the links he provided, and this SO thread, I was able to answer my question.
Below I provide the old ui.R and server.R scripts which generated axis labels I was not happy with, as well as new ui.R and server.R scripts where the axis labels are improved. (Changes in the new scripts are marked with # diff)
old ui.R:
shinyUI(fluidPage(
titlePanel("Fit Regression Line for Chosen Variables and Points"),
sidebarLayout(
sidebarPanel(
h2("Model Specifics"), br(),
selectInput("xvar", "What is the predictor variable?",
choices = list("MPG" = "mpg",
"Cylinders" = "cyl",
"Engine Displacement" = "disp",
"Horse Power" = "hp",
"Gears" = "gear"),
multiple = FALSE),
selectInput("yvar", "What is the outcome variable?",
choices = list("MPG" = "mpg",
"Cylinders" = "cyl",
"Engine Displacement" = "disp",
"Horse Power" = "hp",
"Gears" = "gear"),
multiple = FALSE, selected = "cyl"),
h4("Intercept"), textOutput("int"),
h4("Slope"), textOutput("slope")
),
mainPanel(
br(), h2("Display"), h4("Drag to select which points to include in model"),
plotOutput("plot", brush = brushOpts(id = "brush1"))
)
)
))
old server.R:
shinyServer(function(input, output) {
model <- reactive({
points <- brushedPoints(mtcars, brush = input$brush1,
xvar = input$xvar,
yvar = input$yvar)
if(nrow(points) <= 1) {
return(NULL)
} else {
lm(as.formula(paste0(input$yvar,
"~", input$xvar)),
data = points)
}
})
output$int <- renderText({
if(is.null(model())) {
"Too few data points selected"
} else {
round(model()[[1]][1], 2)
}
})
output$slope <- renderText({
if(is.null(model())) {
"Too few data points selected"
} else {
round(model()[[1]][2], 2)
}
})
output$plot <- renderPlot({
library(ggplot2)
ggplot(mapping = aes(x = mtcars[, input$xvar],
y = mtcars[, input$yvar])) +
theme_minimal() +
geom_point() +
labs(x = input$xvar, y = input$yvar) +
coord_cartesian(x = c(0, 1.2*max(mtcars[, input$xvar])),
y = c(0, 1.2*max(mtcars[, input$yvar]))) +
if(!is.null(model())) {
geom_abline(intercept = model()[[1]][1], slope = model()[[1]][2],
colour = "red", lwd = 2, alpha = 0.3)
}
})
})
Changes in the scripts are marked with # diff
new ui.R:
shinyUI(fluidPage(
titlePanel("Fit Regression Line for Chosen Variables and Points"),
sidebarLayout(
sidebarPanel(
h2("Model Specifics"), br(),
uiOutput("si_xvar"), # diff
uiOutput("si_yvar"), # diff
h4("Intercept"), textOutput("int"),
h4("Slope"), textOutput("slope")
),
mainPanel(
br(), h2("Display"), h4("Drag to select which points to include in model"),
plotOutput("plot", brush = brushOpts(id = "brush1"))
)
)
))
new server.R:
shinyServer(function(input, output) {
varlist <- list("MPG" = "mpg", # diff
"Cylinders" = "cyl",
"Engine Displacement" = "disp",
"Horse Power" = "hp",
"Gears" = "gear")
output$si_xvar <- renderUI( # diff
selectInput("xvar", "What is the predictor variable?",
choices = varlist,
multiple = FALSE)
)
output$si_yvar <- renderUI( # diff
selectInput("yvar", "What is the outcome variable?",
choices = varlist,
multiple = FALSE, selected = "cyl")
)
model <- reactive({
points <- brushedPoints(mtcars, brush = input$brush1,
xvar = input$xvar,
yvar = input$yvar)
if(nrow(points) <= 1) {
return(NULL)
} else {
lm(as.formula(paste0(input$yvar,
"~", input$xvar)),
data = points)
}
})
output$int <- renderText({
if(is.null(model())) {
"Too few data points selected"
} else {
round(model()[[1]][1], 2)
}
})
output$slope <- renderText({
if(is.null(model())) {
"Too few data points selected"
} else {
round(model()[[1]][2], 2)
}
})
output$plot <- renderPlot({
library(ggplot2)
ggplot(mapping = aes(x = mtcars[, input$xvar],
y = mtcars[, input$yvar])) +
theme_minimal() +
geom_point() +
labs(x = names(which(input$xvar == varlist)), # diff
y = names(which(input$yvar == varlist))) + # diff
coord_cartesian(x = c(0, 1.2*max(mtcars[, input$xvar])),
y = c(0, 1.2*max(mtcars[, input$yvar]))) +
if(!is.null(model())) {
geom_abline(intercept = model()[[1]][1], slope = model()[[1]][2],
colour = "red", lwd = 2, alpha = 0.3)
}
})
})

Resources