Related
I have this working app: It is a follow-up question of some previous questions:
library(shiny)
library(vtree)
df <- tibble(A = c(rep("nature", 18), rep("not nature", 9)),
B = rep(c("animal", "plant", "machine"), each=9),
C = c(rep(c("dog", "cat", 'mouse'), 3),
rep(c("tree", "flower", "grass"), 3),
rep(c("car", "plane", "train"), 3)
)
)
# Define UI ----
ui <- pageWithSidebar(
# App title ----
headerPanel("my app"),
# Sidebar panel for inputs ----
sidebarPanel(
selectizeInput("levels", label = "Levels", choices = NULL, multiple = TRUE),
selectizeInput("valuesA", label= "Values_A", choices = NULL, multiple=TRUE),
selectizeInput("valuesB", label= "Values_B", choices = NULL, multiple=TRUE),
selectizeInput("valuesC", label= "Values_C", choices = NULL, multiple=TRUE),
),
# Main panel for displaying outputs ----
mainPanel(
vtreeOutput("VTREE")
)
)
# Define server logic to plot ----
server <- function(input, output,session) {
df <- reactiveVal(df)
vector <- c("A","B", "C")
observe({
updateSelectizeInput(session, "levels", choices = colnames(df()[vector]), selected = NULL)
updateSelectizeInput(session, "valuesA", choices = unique(df()$A))
updateSelectizeInput(session, "valuesB", choices = unique(df()$B))
updateSelectizeInput(session, "valuesC", choices = unique(df()$C))
})
output[["VTREE"]] <- renderVtree({
vtree(df(), c(input$levels),
sameline = TRUE,
keep=list(A=input$valuesA,
B = input$valuesB,
C = input$valuesC),
pngknit=FALSE,
horiz=TRUE,height=450,width=850)
})
}
shinyApp(ui, server)
I want to control the selectizeInput fields in that way that they dependent on each other:
Let me explain:
Scenario 1:
If Levels == A the user should be able to select from Values_A, not Values_B and not Values_C.
Scenario 2:
If Levels==A and Values_A == nature then in Values_B only animal and plant should be visible to select and not machine because machine is not nature.
Scenario 3:
If Levels == A and Values_A == nature and Values_B == animal then in Values_C only dog cat mouse should be visible:
Hi I think this does what you are looking for
library(shiny)
library(vtree)
library(dplyr)
df <- tibble(A = c(rep("nature", 18), rep("not nature", 9)),
B = rep(c("animal", "plant", "machine"), each=9),
C = c(rep(c("dog", "cat", 'mouse'), 3),
rep(c("tree", "flower", "grass"), 3),
rep(c("car", "plane", "train"), 3)
)
)
# Define UI ----
ui <- pageWithSidebar(
# App title ----
headerPanel("my app"),
# Sidebar panel for inputs ----
sidebarPanel(
selectizeInput("levels", label = "Levels", choices = NULL, multiple = TRUE),
selectizeInput("valuesA", label= "Values_A", choices = NULL, multiple=TRUE),
selectizeInput("valuesB", label= "Values_B", choices = NULL, multiple=TRUE),
selectizeInput("valuesC", label= "Values_C", choices = NULL, multiple=TRUE),
),
# Main panel for displaying outputs ----
mainPanel(
vtreeOutput("VTREE")
)
)
# Define server logic to plot ----
server <- function(input, output,session) {
df_A <- reactive({
filtered_df <- df
if(!is.null(input$valuesA)){
filtered_df <- filtered_df %>%
filter(A %in% input$valuesA)
}
filtered_df
})
df_B <- reactive({
if(!is.null(input$valuesB)){
filtered_df <- df_A() %>%
filter(B %in% input$valuesB)
} else {
df_A()
}
})
df_C <- reactive({
if(!is.null(input$valuesC)){
df_B() %>%
filter(C %in% input$valuesC)
} else {
df_B()
}
})
vector <- c("A","B", "C")
observe({
# browser()
updateSelectizeInput(session, "levels", choices = colnames(df[vector]), selected = input$levels)
updateSelectizeInput(session, "valuesA", choices = unique(df$A), selected = input$valuesA)
updateSelectizeInput(session, "valuesB", choices = unique(df_A()$B), selected = input$valuesB)
updateSelectizeInput(session, "valuesC", choices = unique(df_B()$C), selected = input$valuesC)
})
output[["VTREE"]] <- renderVtree({
vtree(df_C(), c(input$levels),
sameline = TRUE,
keep=list(A=input$valuesA,
B = input$valuesB,
C = input$valuesC),
pngknit=FALSE,
horiz=TRUE,height=450,width=850)
})
}
shinyApp(ui, server)
Hope this helps,
Bertil
I have a fully functioning shiny app for performing regression analysis, with summary(), tidy(), and augment().
However, I would like to add a filter selection in the shiny for the uploaded data.
My dataset is quite big and within the dataset, it is divided into 5 types, (so, type_1, type_2, type_3, etc). Right now I have to divide my dataset manually outside the shiny app to 5 different datasets so I can only run the regression for one specific type at a time.
It would be great to be able to choose and select the type within the shiny, without going through all this hassle.
Grateful for all your help.
library(shiny)
library(shinyWidgets)
library(DT)
library(dplyr)
library(nlme)
library(broom)
ui <- navbarPage("dd",
tabPanel("Reg",
sidebarPanel(
fileInput(
inputId = "filedata",
label = "Upload data. csv",
multiple = FALSE,
accept = c(".csv"),
buttonLabel = "Choosing ...",
placeholder = "No files selected yet"
),
uiOutput("xvariable"),
uiOutput("yvariable")
),
mainPanel(
DTOutput("tb1"),
fluidRow(
column(6, verbatimTextOutput('lmSummary')),
column(6,verbatimTextOutput("tid")),
column(6,verbatimTextOutput("aug"))
)
)
)
)
server <- function(input, output, session) {
data_1 <- reactive({
req(input$filedata)
inData <- input$filedata
if (is.null(inData)){ return(NULL) }
mydata <- read.csv(inData$datapath, header = TRUE, sep=",")
})
output$tb1 <- renderDT(head(data_1()))
output$xvariable <- renderUI({
req(data_1())
xa<-colnames(data_1())
pickerInput(inputId = 'xvar',
label = 'Select x-axis variable',
choices = c(xa[1:length(xa)]), selected=xa[2],
options = list(`style` = "btn-info"),
multiple = TRUE)
})
output$yvariable <- renderUI({
req(data_1())
ya<-colnames(data_1())
pickerInput(inputId = 'yvar',
label = 'Select y-axis variable',
choices = c(ya[1:length(ya)]), selected=ya[1],
options = list(`style` = "btn-info"),
multiple = FALSE)
})
lmModel <- reactive({
req(data_1(),input$xvar,input$yvar)
x <- as.numeric(data_1()[[as.name(input$xvar)]])
y <- as.numeric(data_1()[[as.name(input$yvar)]])
current_formula <- paste0(input$yvar, " ~ ", paste0(input$xvar, collapse = " + "))
current_formula <- as.formula(current_formula)
model <- lm(current_formula, data = data_1(), na.action=na.exclude)
return(model)
})
output$lmSummary <- renderPrint({
req(lmModel())
summary(lmModel())
})
output$tid <- renderPrint({
req(lmModel())
tidy(lmModel())
})
output$aug <- renderPrint({
req(lmModel())
augment(lmModel())
})
}
shinyApp(ui, server)
How the uploaded dataset could look like, for better explanation
data_set <- data.frame (Simulation_1 = c(1,2,3,4,5,6,7,8,9,10),
Simulation_2 = c(1,2,3,4,5,6,7,8,9,10),
Simulation_3 = c(1,2,3,4,5,6,7,8,9,10),
type = c("type_1", "type_2", "Type_5",
"type_1", "type_2", "Type_3",
"type_1", "type_2", "Type_1","Type_4")
)
Perhaps you are looking for this
library(shiny)
library(shinyWidgets)
library(DT)
library(dplyr)
library(nlme)
library(broom)
data_set <- data.frame (Simulation_1 = c(1,2,3,4,5,6,7,8,9,10),
Simulation_2 = c(1,2,3,4,5,6,7,8,9,10),
Simulation_3 = c(1,2,3,4,5,6,7,8,9,10),
type = c("type_1", "type_2", "Type_5",
"type_1", "type_2", "Type_3",
"type_1", "type_2", "Type_1","Type_4")
)
ui <- navbarPage("dd",
tabPanel("Reg",
sidebarPanel(
fileInput(
inputId = "filedata",
label = "Upload data. csv",
multiple = FALSE,
accept = c(".csv"),
buttonLabel = "Choosing ...",
placeholder = "No files selected yet"
),
uiOutput("col"),
uiOutput("type"),
uiOutput("xvariable"),
uiOutput("yvariable")
),
mainPanel(
DTOutput("tb1"),
fluidRow(
column(6, verbatimTextOutput('lmSummary')),
column(6,verbatimTextOutput("tid")),
column(6,verbatimTextOutput("aug"))
)
)
)
)
server <- function(input, output, session) {
data_0 <- reactive({
# req(input$filedata)
# inData <- input$filedata
# if (is.null(inData)){ return(NULL) }
# mydata <- read.csv(inData$datapath, header = TRUE, sep=",")
data_set
})
output$tb1 <- renderDT(head(data_1()))
output$col <- renderUI({
req(data_0())
selected = colnames(data_0())[length(colnames(data_0()))]
selectInput("mycol", "Choose column", choices = colnames(data_0()), selected = selected)
})
output$type <- renderUI({
req(data_0(),input$mycol)
selectInput("mytype", "Choose Type", choices = unique(data_0()[[input$mycol]]))
})
data_1 <- eventReactive(input$mytype, {
req(data_0(),input$mycol,input$mytype)
df <- data_0()
df$newvar <- df[[input$mycol]]
df %>% dplyr::filter(newvar %in% input$mytype) %>% dplyr::select(- c(newvar))
})
output$xvariable <- renderUI({
req(data_1())
xa<-colnames(data_1())
pickerInput(inputId = 'xvar',
label = 'Select x-axis variable',
choices = c(xa[1:length(xa)]), selected=xa[2],
options = list(`style` = "btn-info"),
multiple = TRUE)
})
output$yvariable <- renderUI({
req(data_1())
ya<-colnames(data_1())
pickerInput(inputId = 'yvar',
label = 'Select y-axis variable',
choices = c(ya[1:length(ya)]), selected=ya[1],
options = list(`style` = "btn-info"),
multiple = FALSE)
})
lmModel <- reactive({
req(data_1(),input$xvar,input$yvar)
x <- as.numeric(data_1()[[as.name(input$xvar)]])
y <- as.numeric(data_1()[[as.name(input$yvar)]])
current_formula <- paste0(input$yvar, " ~ ", paste0(input$xvar, collapse = " + "))
current_formula <- as.formula(current_formula)
model <- lm(current_formula, data = data_1(), na.action=na.exclude)
return(model)
})
output$lmSummary <- renderPrint({
req(lmModel())
summary(lmModel())
})
output$tid <- renderPrint({
req(lmModel())
tidy(lmModel())
})
output$aug <- renderPrint({
req(lmModel())
augment(lmModel())
})
}
shinyApp(ui, server)
Good morning,
in my dashboard I inserted a checkbox to select one or more output to display. In the ui I entered the checkbox and in the server all the conditions (if ... else if ...). When I launch the app it only shows me a plot, even when I select more than one choice in the checkbox. In addition it gives me this error in console:
"Warning in if (input$checkGroup == 1) { :the condition has length > 1 and only the first element will be used"
I suppose it's telling me that I can't handle more than one choice, how do I view all the plots I choose?
ui <- fluidPage(titlePanel("IULM Dashboard"), sidebarLayout(sidebarPanel(
selectInput("selection", "Choose a Dataset:",
choices = datasets),
("Barplot","Network",'Wordcloud', "LDA-Latent topic"),
#selected = "Barplot", inline = TRUE),
checkboxGroupInput("checkGroup", label = ("Checkbox group"),
choices = list("Barplot" = 1, "Network" = 2), selected = 1, inline = TRUE),
actionButton("update", "Change"))
, mainPanel(
uiOutput("plot")))
server <- function(input, output){
datasetInput <- reactive({
input$update
isolate({
withProgress({
setProgress(message = "Processing corpus...")
getTermMatrix(input$selection)
})
})
})
output$plot <- renderUI({
if(input$checkGroup== 1 ){
output$barplot <- renderPlot({
v=datasetInput()
dtm1 = removeSparseTerms(v, 0.992)
freq <- colSums(as.matrix(dtm1))
wf = data.frame(term = names(freq), occurrences = freq)
wf <- wf[order(wf$occurrences, decreasing = TRUE),]
wf2 = subset(wf[1:input$maxB,])
ggplot(wf2, aes(term, occurrences)) +
geom_bar(stat="identity", fill="darkred", colour="black", width=0.5)+
theme(axis.text.x=element_text(angle=45, hjust=1))+
ggtitle("Word barplot")})
plotOutput(outputId = "barplot", width = 600, height = 400)
}
else if(input$checkGroup== 2 ){
output$network <- renderPlot({
v=datasetInput()
dtm1 = removeSparseTerms(v, 0.992)
rowTotals <- apply(dtm1 , 1, sum)
dtm2 <- dtm1[rowTotals> 0, ]
wdtm <- weightTf(dtm2)
dtm1 <- removeSparseTerms(wdtm, 0.96)
dfm <- as.dfm(dtm1)
textplot_network(dfm, min_freq = 0.5, omit_isolated = TRUE,
edge_color = "#1F78B4", edge_alpha = 0.5, edge_size = 2,
vertex_color = "#4D4D4D", vertex_size = 2,
vertex_labelsize = 5, offset = NULL)})
plotOutput(outputId = "network", width = 600, height = 600)}
})
}
shinyApp(ui = ui, server = server)
You can try
library(shiny)
ui <- fluidPage(
sidebarLayout(
sidebarPanel(
checkboxGroupInput("variable", "Variables to show:",
c("Cylinders" = "cyl",
"Transmission" = "am",
"Gears" = "gear"))
),
mainPanel(
uiOutput("plots")
)))
server <- function(input, output) {
output$plots <- renderUI({
req(input$variable)
output = tagList()
if(any(input$variable %in% "cyl")){
tmp <- mtcars$cyl
output[[1]] <- renderPlot({plot(mtcars$mpg, tmp)})
}
if(any(input$variable %in% "am")){
tmp <- mtcars$am
output[[2]] <- renderPlot({boxplot(mtcars$mpg, tmp)})
}
output
})
}
shinyApp(ui = ui, server = server)
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)
})
}
})
I am trying to build a 'data explorer' shiny app which contains DataTables, ggplot2 graphs and wilcox.test results. I can't seem to make the wilcox.test to work though.
Outside the shiny app, things work as it should:
dat <- data.frame(outcome=sample(c("died","survived",NA), 20, TRUE),
cntr=sample(c("hospa","hospb"), 20, TRUE),
s=rnorm(20),
t=rnorm(20), stringsAsFactors=FALSE)
wilcox.test(dat$s ~ dat$outcome)
Results:
Wilcoxon rank sum test
data: dat$s by dat$outcome
W = 25, p-value = 0.3301
alternative hypothesis: true location shift is not equal to 0
Within the shiny app, the code below gives an 'Error: grouping factor > must have exactly 2 levels'. (graphs & tables work fine; I have omitted these for clarity).
library(shiny)
library(dplyr)
dat <- data.frame(outcome=sample(c("died","survived",NA), 20, TRUE),
cntr=sample(c("hospa","hospb"), 20, TRUE),
s=rnorm(20),
t=rnorm(20), stringsAsFactors=FALSE)
ui <- navbarPage(
sidebarLayout(
sidebarPanel(
selectInput(inputId = "y",
label = "Y-axis:",
choices = c("s"="s", "t"="t"),
selected = "s"),
selectInput(inputId = "z",
label = "Color by:",
choices = c("outcome", "cntr"),
selected = "outcome")
),
mainPanel(
tabsetPanel(id="tabspanel", type = "tabs",
tabPanel(title = "Wilcox"),
h4(textOutput(outputId = "p")))
)
)
)
server <- function(input, output, session) {
df <- reactive({
data.frame(input$y, input$z)
})
output$p <- renderText({
wilcox.test(df()[,1] ~ df()[,2])
})
}
shinyApp(ui=ui, server=server)
If the code is rewritten:
wilcox.test(dat$s, dat$outcome)
then the error is 'Error: 'x' must be numeric'.
Can someone help?
The issue you are having is that the line
data.frame(input$y, input$z)
gets translated to something like
data.frame("s", "outcome")
which can't be reasonably handeled by wicox.text. You should use the following instead
data.frame(dat[[input$y]], dat[[input$z]])
There were also some other minor issues. See the code code below for a full fix.
library(shiny)
library(dplyr)
dat <- data.frame(outcome=sample(c("died","survived",NA), 20, TRUE),
cntr=sample(c("hospa","hospb"), 20, TRUE),
s=rnorm(20),
t=rnorm(20), stringsAsFactors=FALSE)
ui <- navbarPage(
sidebarLayout(
sidebarPanel(
selectInput(inputId = "y",
label = "Y-axis:",
choices = c("s"="s", "t"="t"),
selected = "s"),
selectInput(inputId = "z",
label = "Color by:",
choices = c("outcome", "cntr"),
selected = "outcome")
),
mainPanel(
tabsetPanel(id="tabspanel", type = "tabs",
tabPanel(title = "Wilcox",
verbatimTextOutput(outputId = "p")))
)
)
)
server <- function(input, output, session) {
df <- reactive({
data.frame(dat[[input$y]], dat[[input$z]])
})
output$p <- renderPrint({
wilcox.test(df()[,1] ~ df()[,2])
})
}
shinyApp(ui=ui, server=server)
Gregor's guess is quite spot on; below snippet from the server codes:
dat_subset <- reactive({
req(input$selected_type)
filter(dat, outcome %in% input$selected_type)
})
output$scatterplot <- renderPlot({
ggplot(data = dat_subset(), aes_string(x = input$x, y = input$y, color = input$z)) + geom_boxplot() + labs()
})
output$nsdtable <- DT::renderDataTable({
DT::datatable(data = dat_subset()[, 1:4],
options = list(pageLength = 10),
rownames = FALSE)
})