This question already has answers here:
Sort (order) data frame rows by multiple columns
(19 answers)
Closed 4 years ago.
I created a shiny app and need some help with the subset of my data. I insert a dateRangeInput where the client can filter between a start and end date. This filter is included into my ggplot code, so that the plot always automatically changes when a different date is selected. My problem is it does not filter based on the selected date, the data of partC. The problem is this line of code: geom_line(aes(x = Date, y = OLS.Data[partC]), color="red"). partC is a variable that connects to selectinputs to have access to my dataframe. Example: Client selects input1 = Informed and input2 = Full, partC makes InformedFull (which is the name of one column of my dataset) and so on. So partC is just a a connector of the two inputs, and this is my problem. If I put into my geom_line this code e.g geom_line(aes(x = Date, y = InformedFull), color="red"), instead the above everything works perfect, but I need it with partC.
Here is my ui.R code (only necessary part):
box(
title = "Controls-0",
status = "primary",
solidHeader = TRUE,
width = 3,
height = 142,
dateRangeInput("daterange", "SELECT DATE:", start = min(OLS.Data$Date), end = max(OLS.Data$Date))
),
box(
title = "Investor Control",
status = "primary",
solidHeader = TRUE,
width = 3,
selectInput("investor", label="Select Investor", choices = list("Informed" = "Informed", "Noise" = "Noise"), selected = "Informed")
),
box(
title = "Category Control",
status = "primary",
solidHeader = TRUE,
width = 3,
selectInput("category", label="Select Category", choices = list("Full" = "Full", "Fact" = "Fact", "Fact Positive" = "Fact.Pos", "Fact Negative" = "Fact.Neg", "Emotions" = "Emotions", "Emotions Fact" = "EmotionsFact"), selected = "Full")
),
Update server.R with ggplot:
server <- function(input, output) {
partC = NULL
makeReactiveBinding("partC")
observeEvent(input$investor, {
partA<<-input$investor
partA<<-as.character(partA)
})
observeEvent(input$category, {
partB<<-input$category
partB<<-as.character(partB)
})
OLS.Data$InformedEmotionsFact <- as.numeric(as.character(OLS.Data$InformedEmotionsFact))
OLS.Data$NoiseEmotionsFact <- as.numeric(as.character(OLS.Data$NoiseEmotionsFact))
output$myPlotVisu <- renderPlot({
partC<-as.character(paste(partA,partB,sep=""))
OLS.Data %>%
select(partC, NYSE,Date,Sector) %>%
filter(Date >= input$daterange[1], Date <= input$daterange[2]) %>%
ggplot(aes(x = Date, y = NYSE)) +
geom_line() +
ggtitle(paste(input$investor,input$category,sep = "")) +
theme(plot.title = element_text(hjust = 0.5,face="bold")) +
labs(x="Time",y="Return S&P500") +
geom_line(aes(x = Date, y = OLS.Data[partC]), color="red")
})
I dont know why you assign partA/partB to the global environment, and even twice. You dont need to do that. I created an reactiveValues object instead, where you store the values (partA, partB and partC). Then you can use them wherever you want in your app.
Maybe the following example will help you with your code. I created some dummy data for it.
library(shiny)
library(shinydashboard)
library(ggplot2)
## DATA #######################
DateSeq = seq(as.Date("1910/1/1"), as.Date("1911/1/1"), "days")
OLS.Data = data.frame(
ID = 1:length(DateSeq),
Date = DateSeq,
NoiseEmotionsFact = sample(1:100,length(DateSeq), T),
InformedEmotionsFact = sample(100:1000,length(DateSeq), T),
InformedFull = sample(10:1000,length(DateSeq), T),
NoiseFull = sample(50:5000,length(DateSeq), T),
NoiseFact = sample(1:15,length(DateSeq), T),
NoiseFact.Pos = sample(100:110,length(DateSeq), T),
NoiseFact.Pos = sample(10:200,length(DateSeq), T)
)
## UI #######################
ui <- {dashboardPage(
dashboardHeader(),
dashboardSidebar(),
dashboardBody(
plotOutput("myPlot"),
box(
title = "Controls-0",
status = "primary",
solidHeader = TRUE,
width = 3,
height = 142,
dateRangeInput("daterange", "SELECT DATE:", start = min(OLS.Data$Date), end = max(OLS.Data$Date))
),
box(
title = "Alpha",
sliderInput("alphaVisu", label = "Alpha :", min = 0, max = 1, value = 0.4, step = 0.1)
),
box(
title = "Investor Control",
status = "primary",
solidHeader = TRUE,
width = 3,
selectInput("investor", label="Select Investor",
choices = list("Informed" = "Informed", "Noise" = "Noise"), selected = "Informed")
),
box(
title = "Category Control",
status = "primary",
solidHeader = TRUE,
width = 3,
selectInput("category", label="Select Category",
choices = list("Full" = "Full", "Fact" = "Fact", "Fact Positive" = "Fact.Pos",
"Fact Negative" = "Fact.Neg", "Emotions" = "Emotions",
"Emotions Fact" = "EmotionsFact"), selected = "Full")
)
)
)}
## SERVER #######################
server <- function(input, output) {
## Reactive Values ############
parts <- reactiveValues(partA=NULL, partB=NULL, partC=NULL)
## Observe Events ############
observeEvent(input$investor, {
parts$partA <- as.character(input$investor)
})
observeEvent(input$category, {
parts$partB <- as.character(input$category)
})
## Plot ############
output$myPlot <- renderPlot({
parts$partC <- as.character(paste(parts$partA, parts$partB,sep=""))
OLS.Data.filtered <- OLS.Data %>%
filter(Date >= input$daterange[1], Date <= input$daterange[2])
req(OLS.Data.filtered)
OLS.Data.filtered %>%
ggplot(aes(x = Date, y = ID)) +
geom_line() +
ggtitle(paste("input$investor","input$category",sep = "")) +
theme(plot.title = element_text(hjust = 0.5,face="bold")) +
labs(x="Time",y="Return S&P500") +
geom_line(aes(x = Date, y = OLS.Data.filtered[parts$partC]), color="red",
alpha = rep(as.numeric(input$alphaVisu), nrow(OLS.Data.filtered[parts$partC])))
})
}
shinyApp(ui, server)
Related
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)
I have an shiny dashboard that contains multiple tabpanels, boxes that has datatable and plots.
With in the first panel tab, I have a datatable followed by two plot objects. I have put the plots into separate collapsible boxes. The issue I have is the plot is overlapping. I tried adjusting the heights to the box/tab box but I still get the overlapping plot.
I am looking at the 'Drug' tabpanel and the two plot objects are: plotlyOutput("drug_cleveland_plot") and plotOutput("drug_forest_plot").
I set the height of the box : height = 3000
Height of the plot that is overlapping: height = 1000
UI:
tabItem(
tabName = "comorbidities",
box(title = p("Medical History",
div(class = "qv_buttons",
actionButton("run_med_history", "Generate Report", icon = icon("refresh")),
shinyWidgets::radioGroupButtons("med_history_pop", label = NULL,
choices = list(#"Previously & Newly Diagnosed",
"Previously Diagnosed",
"Newly Diagnosed"),
selected = "Previously Diagnosed")
)
),
status = "success",
solidHeader = TRUE,
width = 12,
box(
width = 12 ,
height = 3000,
br(),
tabBox(
id = "med_history_tab",
tabPanel(
"Drug",
pickerInput(
inputId = "drug_class_selection",
label = "Drug Class:",
choices = c('ATC 1st', 'ATC 2nd', 'ATC 3rd', 'ATC 4th', 'ATC 5th', 'Ingredient'),
width = '50%'
),
DT::dataTableOutput("truven_med_history_drug_table", width = "850px"),
box(title = "Expected vs Observed Proportion Cleveland Plot",
collapsible = TRUE,collapsed = TRUE, plotlyOutput("drug_cleveland_plot"),width = "100%"),
box(title = "Expected vs Observed Proportion Odds Ratio",
collapsible = TRUE,collapsed = TRUE, plotOutput("drug_forest_plot"),width = "100%")),
tabPanel(
"Condition",
pickerInput(
inputId = "condition_hrc_selection",
label = "Condition Level:",
choices = c(0,1),
choicesOpt = list(subtext = c(" : Acual"," : 1 Level Higher")),
width = '50%'
),
#verbatimTextOutput('sel.cond'),
DT::dataTableOutput("truven_med_history_condition_table"),
actionButton('resetSelection', label = "Click to reset row selection"),
plotlyOutput('cond_cleveland_plot')
),
tabPanel(
"Procedure",
pickerInput(
inputId = "procedure_hrc_selection",
label = "Procedure Level:",
choices = c(0,1),
choicesOpt = list(subtext = c(" : Acual"," : 1 Level Higher")),
width = '50%'
),
#verbatimTextOutput('sel.proc'),
DT::dataTableOutput("truven_med_history_procedure_table")
),
tabPanel(
"Charlson Cormobidity",
DT::dataTableOutput("truven_med_history_cci_table"),
plotlyOutput("truv_cci_bar_plotly"),
br(),
plotlyOutput("cci_bar_plotly")
),
#plotOutput("truven_atc1_plot"),
#plotOutput("truven_icd3_plot")#,
#DT::dataTableOutput("truven_med_history_drug_table")
width = 12,
height = 3000
)
)
Code to create the plot
Server:
# drug cleaveland plot
output$drug_cleveland_plot = renderPlotly({
df <- df_drug_plot()
df <- sqldf("select distinct concept_name,w_cond_rate as rate,'Diagnosed' as grp from df
union
select distinct concept_name,w_exp_rate as rate,'Expected' as grp from df
")
df <- df %>%
arrange(rate) %>% mutate(grp = factor(grp)) %>%
mutate(concept_name=factor(concept_name))
p <- df %>%
arrange(grp, rate, desc(concept_name)) %>%
ggplot(aes(rate, fct_inorder(concept_name))) +
geom_line(aes(group = concept_name)) +
geom_point(aes(color = grp)) +
scale_x_continuous(breaks = seq(0, 1.1, by = 0.1)) +
theme_bw() +
theme(panel.grid.major.x = element_line( linetype = "dotted", size = 0.2, color = 'grey' )) +
scale_colour_manual(values=c("#d91e4a", "#939597")) +
theme (legend.title=element_blank())
m <- list(
l = 200,
r = 100,
b = 100,
t = 100,
pad = 5
)
fig <- ggplotly(p,width = 1500, height = 1000) %>% layout(title = "Drugs: Observed vs Expected Proportion",
autosize = F,
margin = m,
yaxis = list(title = "",
automargin = TRUE),
legend = list(title=list(text='<b> Group </b>')))
fig
})
I am creating my first shiny app and I have added a navbar. When I run my first code with the corona virus stuff it runs and my data appears but when I try to add my code for my second tab within the navbar, both tabs appear as well as the layouts and inputs but then neither data sets show up so the pages are empty. Any help would be appreciated ! Thanks !
ui <-fluidPage(
navbarPage("Navigation bar!",
tabPanel("Corona Virus Data",
titlePanel("Spread of Corona Virus and it's effects"),
sidebarLayout(
sidebarPanel = sidebarPanel(
selectInput(
inputId = "continentInput",
label = "Continent",
choices =
unique(new_corona$continent)[1:5] %>%
sort()
)),
mainPanel = mainPanel(
plotOutput(outputId = "ContiPlot"),
br(), br(),
tableOutput(outputId = "ContiTable"),
tabsetPanel(type = "tabs",
tabPanel("Corona Cases",
plotOutput("coronaPlot"),
)
)
)
)),
tabPanel("Schooling Data",
titlePanel("How many kids have Internet ?"),
sidebarLayout(
sidebarPanel = sidebarPanel(
selectInput(
inputId = "raceInput",
label = "Race",
choices =
unique(Internet_access_by_race$new_races)[1:5] %>%
sort
)),
mainPanel = mainPanel(
plotOutput(outputId = "racePlot"),
br(), br(),
tableOutput(outputId = "raceTable"),
tabsetPanel(type = "tabs",
tabPanel("Race & Education data",
plotOutput("racePlot")
)
))
)
)
)
)
server <-function(input, output){
filtered_data <- reactive({
filtered <- new_corona %>%
filter(continent == input$continentInput)
})
output$ContiPlot <- renderPlot({
ggplot(data = filtered_data(),
aes(y = cases,
x = country,
color = country,
fill = country
)) +
scale_x_discrete(guide = guide_axis(n.dodge = 5)) +
ggtitle("Cases By Country") +
theme_dark()+
theme(plot.title = element_text(hjust = 0.5))+
ylab("Cases") +
xlab("Country")+
geom_bar(stat = "identity", width = 0.8, na.rm = TRUE)
})
output$ContiTable <- renderTable({
filtered_data <- new_corona %>%
filter(continent == input$continentInput)
})
filt <-reactive({
filted_2 <- Internet_access_by_race %>%
filter(new_races == input$raceInput)
})
output$racePlot <-renderPlot({
gplot(data = filt(),
aes(x = access_2,
y = RACE,
fill = new_races)) +
scale_x_discrete(guide = guide_axis(n.dodge = 7)) +
ggtitle("Accessessbility to Education by race") +
theme_dark()+
theme(plot.title = element_text(hjust = 0.5))+
ylab("Totals") +
xlab("Access") +
labs()
geom_bar(stat = "identity", width = 0.8, na.rm = TRUE)
})
output$raceTable <- renderTable({
filt <-Internet_access_by_race %>%
filter(new_races == input$raceInput)
})
}
shinyApp(ui = ui, server = server)
--------Data------------
dput(head(new_corona))
346769 = 346769L, 346780 = 346780L, 346961 = 346961L, 347016 = 347016L,
347028 = 347028L, 347039 = 347039L, 347220 = 347220L, 347275 = 347275L,
347287 = 347287L, 347298 = 347298L, 347479 = 347479L, 347534 = 347534L,
347546 = 347546L, 347557 = 347557L, 347738 = 347738L, 347793 = 347793L,
347805 = 347805L, 347816 = 347816L, 347997 = 347997L, 348052 = 348052L,
348064 = 348064L, 348075 = 348075L, 348256 = 348256L, 348311 = 348311L,
348323 = 348323L, 348334 = 348334L, 348515 = 348515L, 348570 = 348570L,
348582 = 348582L, 348593 = 348593L, 348774 = 348774L, 348829 = 348829L,
348841 = 348841L, 348852 = 348852L, 349033 = 349033L, 349088 = 349088L,
349100 = 349100L, 349111 = 349111L, 349292 = 349292L, 349347 = 349347L,
349359 = 349359L, 349370 = 349370L, 349551 = 349551L, 349606 = 349606L,
349618 = 349618L, 349629 = 349629L, 349810 = 349810L, 349865 = 349865L,
349877 = 349877L, 349888 = 349888L, 350069 = 350069L, 350124 = 350124L,
350136 = 350136L, 350147 = 350147L), class = "omit"), row.names = c(NA,
6L), class = "data.frame")
dput(head(Internet_access_by_race)) structure(list(RACE = c(9622067, 3159471, 1229306, 537123, 187261, 235178), access_2 = c("Always haved device", "Usually have device", "Sometimes have device", "Rarely have device", "Device unavailable", "did not report about devices"), new_races = c("Hispanic_or_latino", "Hispanic_or_latino", "Hispanic_or_latino", "Hispanic_or_latino", "Hispanic_or_latino", "Hispanic_or_latino")), row.names = c(NA, 6L), class = "data.frame")
I'm creating a shiny app, and I want one of my tabs to be a 13 question quiz/game. However, I don't want all 13 questions displayed at once. I want to include an action button that when the user presses, the next question is displayed. Currently, both questions are displayed. Also, will I need to create separate action buttons for each question?
Problem 2: Questions 1-5 use the same plot. Questions 6-13 will use a different plot, and I will want both the question and the plot to be changed after question 5. I've provided 2 questions as an example.
In my UI script I have:
navbarPage(
"NEO Guess Who", position = "fixed-top",
tabPanel("Quiz",
fluidPage(
titlePanel(h1("Do you even know us?")),
sidebarLayout(
sidebarPanel(
radioButtons("q1", "Whose personality is plotted as the purple line?",
choices = list("Amy" = "Amy",
"Claire" = "Claire",
"Olivia" = "Olivia",
"Shae" = "Shae",
"Sharon" = "Sharon"),
selected = character(0)),
textOutput("q1text"),
actionButton("q1action", "Next", class = "btn-success"),
radioButtons("q2", "Whose personality is plotted as the blue line?",
choices = list("Amy" = "Amy",
"Claire" = "Claire",
"Olivia" = "Olivia",
"Shae" = "Shae",
"Sharon" = "Sharon"),
selected = character(0))),
mainPanel(
plotOutput("plot7"))
)))
)
within the server script, I have:
output$q1text <- renderText({
q1 <- switch (input$q1,
Amy = paste("Oops, the correct answer is Sharon"),
Claire = paste("Oops, the correct answer is Sharon"),
Olivia = paste("Oops, the correct answer is Sharon"),
Shae = paste("Oops, the correct answer is Sharon"),
Sharon = paste("Correct!"),
)
})
observeEvent(input$q1action, {
updateRadioButtons(session, "q1", choices = c("Amy", "Claire", "Olivia", "Shae", "Sharon"), selected = 0)
updateRadioButtons(session, "q2", choices = c("Amy", "Claire", "Olivia", "Shae", "Sharon"), selected = 0)
})
# both questions are still displayed
# no legend
output$plot7 <- renderPlot({
{neo_simple <- read.csv("neo_simple.csv", header = T, sep = ",")}
{neo_simple$domain <- factor(neo_simple$domain, levels = c("neuroticism", "extraversion", "openness", "agree", "conscient"))}
{neoColors <-
setNames( c('#a6cee3', '#b2df8a', '#fb9a99', '#fdbf6f', '#cab2d6'),
levels(neo_simple$id) )}
neo_simple %>%
ggplot(aes(x = domain, y=tscore, group = id, color = id)) +
geom_point(size = 1.75) +
scale_color_manual(values = neoColors) +
geom_line(size = 1.25) +
theme_bw() +
ggtitle("NEO Domain Scores") +
theme(plot.title = element_text(hjust = 0.5, size = 15)) +
theme(text = element_text(size=rel(4.5))) +
theme(legend.position = "none") +
theme(plot.caption = element_text(hjust = 0, size = 14))
})
Perhaps the 'slickR' package is a possible way:
library(shiny)
library(slickR)
ui <- fluidPage(
slickROutput("questions", width = "50%")
)
server <- function(input, output, session){
output[["questions"]] <- renderSlickR({
slickR(
slick_list(
radioButtons(
"q1",
"First question",
choices = c("Yes", "No")
),
radioButtons(
"q2",
"Second question",
choices = c("True", "False")
)
)
)
})
}
shinyApp(ui, server)
I have added multiple select inputs to my shiny app in the sidebar and in the main body and want to create a graph that will change when any of those inputs have been selected or changed but I keep getting the error Warning: Error in : Result must have length 56127, not 0.
UI:
ui <- dashboardPage(
dashboardHeader(title = "Human Trafficking"),
dashboardSidebar(
sidebarMenu(
selectInput("Source", "Choose a Data Source: ", choices = " ", selected = NULL,
multiple = TRUE, selectize = TRUE, width = NULL, size = NULL),
dateInput("startdate", "Start Date:", value = "2009-01-01", format = "dd-mm-yyyy",
min = "2009-01-01", max = "2019-08-26"),
dateInput("enddate", "End Date:", value = "2019-08-27", format = "dd-mm-yyyy",
min = "2009-01-02", max = "2019-08-27"),
selectInput("Nationality", "Select a nation: ", choices = " "),
actionButton("button", "Apply")
)
),
dashboardBody(
fluidRow(
box(width = 4, solidHeader = TRUE,
selectInput("traffickingType", "Choose a trafficking type: ", choices = " ", selected = NULL,
multiple = TRUE, selectize = TRUE, width = NULL, size = NULL)
),
box(width = 4, solidHeader = TRUE,
selectInput("traffickingSubType", "Choose a trafficking sub type: ", choices = " ", selected = NULL,
multiple = TRUE, selectize = TRUE, width = NULL, size = NULL)
),
box(width = 4, solidHeader = TRUE,
selectInput("gender", "Choose a gender: ", choices = " ", selected = NULL,
multiple = TRUE, selectize = TRUE, width = NULL, size = NULL)
)
),
fluidRow(
box(width = 12,
plotlyOutput('coolplot')
)
)
)
)
Server:
server <- function(input, output, session) {
genderVic = sort(unique(ngo$Victim.Gender))
updateSelectInput(session, "gender", choices = genderVic)
traffickingSub = sort(unique(ngo$Trafficking.Sub.Type))
updateSelectInput(session, "traffickingSubType", choices = traffickingSub)
trafficking = sort(unique(ngo$Trafficking.Type))
updateSelectInput(session, "traffickingType", choices = trafficking)
traffickerNationalities = sort(unique(ngo$Trafficker.Nationality))
updateSelectInput(session, "TraffickerNation", choices = traffickerNationalities)
dataSource = sort(unique(ngo$Data.Provided.By))
updateSelectInput(session, "Source", choices = dataSource)
nationalities = sort(unique(ngo$Victim.Nationality))
updateSelectInput(session, "Nationality", choices = nationalities)
output$coolplot <- renderPlotly({
ngo <-
ngo %>%
filter(Victim.Nationality == input$Nationality,
Victim.Gender == input$gender,
Trafficking.Type == input$traffickingType
)
p = ggplot(ngo, aes(x = Victim.Age, fill = Trafficking.Type)) +
geom_bar(position = "stack")
ggplotly(p) %>%
layout(showlegend = FALSE)
})
}
So currently only have it calling three of the inputs to test it but still getting an error.
It should work after the error is displayed once you select a gender and trafficking type in your example. The reason for the error is that renderPlotly is expecting values for input$traffickingType and input$gender but these start out as NULL.
Add a req for each of those selectInputs:
output$coolplot <- renderPlotly({
ngo <-
ngo %>%
filter(Victim.Nationality == input$Nationality,
Victim.Gender == req(input$gender),
Trafficking.Type == req(input$traffickingType)
)
p = ggplot(ngo, aes(x = Victim.Age, fill = Trafficking.Type)) +
geom_bar(position = "stack")
ggplotly(p) %>%
layout(showlegend = FALSE)
})