How to use a reactive variable in server Shiny - r

I would like to create an application such as below, only at the beginning is to choose the number of cylinders. The following example selects a database, I would like to give up and go straight to the selection of cylinders. Can I use the filter option here?
My idea:
df_mtcars <- reactive({
cylinder_selected <- as.numeric(input$si_cylinders[1])
df <- mtcars %>% filter(cyl == cylinder_selected)
return(df)
})
My code:
ui:
library(radarchart)
shinyUI(pageWithSidebar(
headerPanel("Car Comparison Radar"),
sidebarPanel(
uiOutput("choose_dataset"),
uiOutput("choose_car"),
uiOutput("choose_columns")
),
mainPanel(
chartJSRadarOutput('radar', height = '350px')
)
))
server:
library(shiny)
library(radarchart)
shinyServer(function(input, output) {
# choose dataset but I want choose cyl
output$choose_dataset <- renderUI({
data_sets <- "mtcars"
selectInput("dataset", "Data set", data_sets)
})
# select a car
output$choose_car <- renderUI({
selectInput("car","car",as.list(rownames(get(input$dataset))))
})
# Check boxes
output$choose_columns <- renderUI({
# If missing input, return to avoid error later in function
if(is.null(input$dataset))
return()
# Get the data set with the appropriate name
dat <- get(input$dataset)
colnames <- names(dat)
# Create the checkboxes and select them all by default
checkboxGroupInput("columns", "Choose columns",
choices = colnames,
selected = colnames)
})
output$radar <- renderChartJSRadar({
# Get the data set
dat <- get(input$dataset)
# Make sure columns are correct for data set (when data set changes, the
# columns will initially be for the previous data set)
if (is.null(input$columns) || !(input$columns %in% names(dat)))
return()
# Keep the selected columns
dat <- dat[, input$columns, drop = FALSE]
#reform data for plot
dat <- as.data.frame(t(dat), stringsAsFactors = FALSE)
dat$labs <- row.names(dat)
dat <- dat[, c('labs', input$car)]
chartJSRadar(dat)
})
})

As it is uiOutput("choose_car") gives you all car possibilities. If you add a selectInputfor selection of cylinders you will have a problem, because you have some specific cars for each cylinder numbers.
So you could have your selectInputfor cars conditional on selectInputfor cylinders.
You can remove uiOutput("choose_dataset") on your own so based on your example you could try this:
ui = pageWithSidebar(
headerPanel("Car Comparison Radar"),
sidebarPanel(
uiOutput("choose_dataset"),
uiOutput("choose_cyclinder"),
uiOutput("choose_car"),
uiOutput("choose_columns")
),
mainPanel(
chartJSRadarOutput('radar', height = '350px')
)
)
server = function(input, output) {
output$choose_cyclinder <- renderUI({
temp <- mtcars %>% group_by(cyl) %>% summarise(Counts = n())
cyl <- levels(as.factor(temp$cyl))
selectInput("select_cyl", "Choose a cylinder", as.list(cyl), selected=TRUE, multiple = FALSE)
})
# choose dataset but I want choose cyl
output$choose_dataset <- renderUI({
data_sets <- "mtcars"
selectInput("dataset", "Data set", data_sets)
})
# select a car
output$choose_car <- renderUI({
dat <- get(input$dataset)
dat <- dat %>% tibble::rownames_to_column('carnames') %>%
filter(cyl %in% c(input$select_cyl)) %>%
tibble::column_to_rownames('carnames')
selectInput("car","car",as.list(rownames(dat)))
})
# Check boxes
output$choose_columns <- renderUI({
# If missing input, return to avoid error later in function
if(is.null(input$dataset))
return()
# Get the data set with the appropriate name
dat <- get(input$dataset)
colnames <- names(dat)
# Create the checkboxes and select them all by default
checkboxGroupInput("columns", "Choose columns",
choices = colnames,
selected = colnames)
})
output$radar <- renderChartJSRadar({
# Get the data set
dat <- get(input$dataset)
# dat <- mtcars
# Make sure columns are correct for data set (when data set changes, the
# columns will initially be for the previous data set)
if (is.null(input$columns) || !(input$columns %in% names(dat)))
return()
# Keep the selected columns
dat <- dat[, input$columns, drop = FALSE]
# dat <- dat %>% filter(cyl %in% c(input$select_cyl))
#reform data for plot
dat <- as.data.frame(t(dat), stringsAsFactors = FALSE)
dat$labs <- row.names(dat)
dat <- dat[, c('labs', input$car)]
chartJSRadar(dat)
})
}
shinyApp(ui, server)
EDIT:
ui = pageWithSidebar(
headerPanel("Car Comparison Radar"),
sidebarPanel(
#uiOutput("choose_dataset"),
uiOutput("choose_cyclinder"),
uiOutput("choose_car"),
uiOutput("choose_columns")
),
mainPanel(
chartJSRadarOutput('radar', height = '350px')
)
)
server = function(input, output) {
output$choose_cyclinder <- renderUI({
temp <- mtcars %>% group_by(cyl) %>% summarise(Counts = n())
cyl <- levels(as.factor(temp$cyl))
selectInput("select_cyl", "Choose a cylinder", as.list(cyl), selected=TRUE, multiple = FALSE)
})
# choose dataset but I want choose cyl
# output$choose_dataset <- renderUI({
# data_sets <- "mtcars"
# selectInput("dataset", "Data set", data_sets)
# })
# select a car
output$choose_car <- renderUI({
# dat <- get(mtcars)
dat <- mtcars
dat <- dat %>% tibble::rownames_to_column('carnames') %>%
filter(cyl %in% c(input$select_cyl)) %>%
tibble::column_to_rownames('carnames')
selectInput("car","car",as.list(rownames(dat)))
})
# Check boxes
output$choose_columns <- renderUI({
# If missing input, return to avoid error later in function
# if(is.null(input$dataset))
# return()
# Get the data set with the appropriate name
# dat <- get(input$dataset)
dat <- mtcars
colnames <- names(dat)
# Create the checkboxes and select them all by default
checkboxGroupInput("columns", "Choose columns",
choices = colnames,
selected = colnames)
})
output$radar <- renderChartJSRadar({
# Get the data set
#dat <- get(input$dataset)
dat <- mtcars
# Make sure columns are correct for data set (when data set changes, the
# columns will initially be for the previous data set)
if (is.null(input$columns) || !(input$columns %in% names(dat)))
return()
# Keep the selected columns
dat <- dat[, input$columns, drop = FALSE]
# dat <- dat %>% filter(cyl %in% c(input$select_cyl))
#reform data for plot
dat <- as.data.frame(t(dat), stringsAsFactors = FALSE)
dat$labs <- row.names(dat)
dat <- dat[, c('labs', input$car)]
chartJSRadar(dat)
})
}
shinyApp(ui, server)

Related

Filter dataframe by factor after selected input in server

I have two dataframes (df1 and df2) which are identical. I want a shiny app were the user firstly select one of the dataframes and secondly filter by a specific column value (in the example data the column region) and get a table in return. I manage to achieve the first task but can't seem to figure out how to do the second one. I have made several attempts with the combination of reactive and filter without any success. I have made a comment in the script below were I made the attempts.
library(shiny)
#Dataset
names_df1 <- c("Henry","Charles","Lisa","Jessica","Steven","Ali","Mona","Patricia","George","John")
region_df1 <- sample(c("North","West","East","South"),10,replace=T)
df1 <- data.frame(names_df1,region_df1)
names_df2 <- c("Michael","Simone","Anna","Steven","Billie","Emma","Maria","Gordon","Bruce","Rachel")
region_df2 <- sample(c("North","West","East","South"),10,replace=T)
df2 <- data.frame(names_df2,region_df2)
colnames(df1) <- c("Names","Region")
colnames(df2) <- c("Names","Region")
ui <- fluidPage(
titlePanel("Shiny Text"),
sidebarLayout(
sidebarPanel(
selectInput(inputId = "dataset",
label = "df1/df2:",
choices = c("df1", "df2")),
selectInput("region",
"Region:",
c("All","North","West","East","South")),
numericInput(inputId = "obs",
label = "Number of observations to view:",
value = 20)),
mainPanel(
tableOutput("view")
)
)
)
server <- function(input, output) {
#Chose input
datasetInput <- reactive({
switch(input$dataset,
"df1" = df1,
"df2" = df2)
})
#Do I filter here?
#Render table
output$view <- renderTable({
head(datasetInput(), n = input$obs)})
}
shinyApp(ui, server)
Can anybody give me some directions?
Best/John
You need something like that:
#Render table
output$view <- renderTable({
out <- datasetInput()
if (input$region != "All") {
out <- out[out$Region == input$region, ]
}
head(out, n = input$obs)
})

Combining R shiny checkboxGroupInput with other input selections

I have these data I want to scatter plot using an R shiny server:
library(dplyr)
library(permute)
set.seed(1)
meta.df <- data.frame(gene_id=paste0("id",1:10),symbol=paste0("n",rep(permute::shuffle(5),2)),stringsAsFactors=F)
clusters.df <- data.frame(cell=paste0("c",1:100),cluster=rep(permute::shuffle(10),10),sample=paste0("s",rep(permute::shuffle(5),20)),stringsAsFactors=F)
mat <- matrix(rnorm(10*100),10,100,dimnames=list(meta.df$gene_id,clusters.df$cell))
tsne.obj <- Rtsne::Rtsne(t(mat))
tsne.df <- as.data.frame(tsne.obj$Y) %>% dplyr::rename(tSNE1=V1,tSNE2=V2) %>% cbind(clusters.df)
samples <- c("all",unique(clusters.df$sample))
samples.choices <- 1:length(samples)
names(samples.choices) <- samples
Since I want to be able to select a specific meta.df$symbol, which is redundant within meta.df$gene_id, each has a selection list, where the second is conditioned on the first.
Since the data are comprised of several samples, I'd like to be able to subset the data by sample in a reactive way, hence I have a sample choice checkbox, with the "all" option that selects all samples (just coz it's easier than checking all boxes).
So here's my shiny code:
server <- function(input, output)
{
chosen.samples <- reactive({
validate(
need(input$samples.choice != "",'Please choose at least one of the sample checkboxes')
)
samples.choice <- input$samples.choice
if("all" %in% samples.choice) samples.choice <- samples[-which(samples == "all")]
samples.choice
})
output$gene_id <- renderUI({
selectInput("gene_id", "Gene ID", choices = unique(dplyr::filter(meta.df,symbol == input$symbol)$gene_id))
})
scatter.plot <- reactive({
if(!is.null(input$symbol) & !is.null(input$gene_id)){
# subset of data
gene.symbol <- input$symbol
gene.id <- input$gene_id
row.idx <- which(rownames(mat) == gene.id)
col.idx <- which(colnames(mat) %in% dplyr::filter(clusters.df,sample %in% chosen.samples())$cell)
gene.df <- suppressWarnings(dplyr::left_join(tsne.df %>% dplyr::filter(sample %in% chosen.samples()),data.frame(cell=colnames(mat)[col.idx],value=mat[row.idx,col.idx],stringsAsFactors=F),by=c("cell"="cell")))
scatter.plot <- plotly::plot_ly(marker=list(size=12),type='scatter',mode="markers",color=~gene.df$value,x=~gene.df$tSNE1,y=~gene.df$tSNE2,showlegend=F) %>%
plotly::layout(xaxis=list(title="tSNE1",zeroline=F,showticklabels=F),yaxis=list(title="tSNE2",zeroline=F,showticklabels=F))
scatter.plot
}
})
output$Embedding <- renderPlot({
scatter.plot()
})
output$save <- downloadHandler(
filename = function() {
paste0(dplyr::filter(meta.df,symbol == input$symbol,gene_id == input$gene_id)$symbol,"_",dplyr::filter(meta.df,symbol == input$symbol,gene_id == input$gene_id)$gene_id,".pdf")
},
content = function(file) {
plotly::export(scatter.plot(),file=file)
}
)
}
ui <- fluidPage(
# App title ----
titlePanel("Results Explorer"),
# Sidebar layout with a input and output definitions ----
sidebarLayout(
# Sidebar panel for inputs ----
sidebarPanel(
# select samples
checkboxGroupInput("samples.choice", "Samples",choices = samples.choices,selected=1),
# select gene symbol
selectInput("symbol", "Gene Symbol", choices = unique(meta.df$symbol)),
# select gene id
uiOutput("gene_id"),
# select plot type
selectInput("plot.type", "Plot Type", choices = c("tSNE","PCA")),
# save plot as html
downloadButton('save', 'Save as PDF')
),
# Main panel for displaying outputs ----
mainPanel(
# The plot is called Embedding and will be created in ShinyServer part
plotOutput("Embedding")
)
)
)
shinyApp(ui = ui, server = server)
The problem is that it doesn't seem to actually select the samples, and hence the plot that is displayed has no points.
It works find if I simply eliminate the samples selection code by replacing:
col.idx <- which(colnames(mat) %in% dplyr::filter(clusters.df,sample %in% chosen.samples())$cell)
gene.df <- suppressWarnings(dplyr::left_join(tsne.df %>% dplyr::filter(sample %in% chosen.samples()),data.frame(cell=colnames(mat)[col.idx],value=mat[row.idx,col.idx],stringsAsFactors=F),by=c("cell"="cell")))
with:
col.idx <- which(colnames(mat) %in% dplyr::filter(clusters.df,sample %in% samples[2:3])$cell)
gene.df <- dplyr::left_join(tsne.df %>% dplyr::filter(sample %in% samples[2:3]),data.frame(cell=colnames(mat)[col.idx],value=mat[row.idx,col.idx],stringsAsFactors=F),by=c("cell"="cell"))
I see that in this example the entire data are subsetted in the dat_reac reactive block. I'd expect simply getting the samples to subset by would be enough. Any idea why it doesn't work and how to get it right?
There are two mistakes in your code. The first one is in checkboxGroupInput
Instead of
checkboxGroupInput("samples.choice", "Samples",choices = samples.choices,selected=1)
it should be
checkboxGroupInput("samples.choice", "Samples",choices = names(samples.choices),selected="all")
The second is scatter.plot() is plotly object hence you should use plotly::plotlyOutput("Embedding") and output$Embedding <- plotly::renderPlotly({
scatter.plot()
})
Here is the code with above modification which should work:
server <- function(input, output)
{
chosen.samples <- reactive({
validate(
need(input$samples.choice != "",'Please choose at least one of the sample checkboxes')
)
samples.choice <- input$samples.choice
if("all" %in% samples.choice) samples.choice <- samples[-which(samples == "all")]
samples.choice
})
output$gene_id <- renderUI({
selectInput("gene_id", "Gene ID", choices = unique(dplyr::filter(meta.df,symbol == input$symbol)$gene_id))
})
scatter.plot <- reactive({
if(!is.null(input$symbol) & !is.null(input$gene_id)){
# subset of data
gene.symbol <- input$symbol
gene.id <- input$gene_id
row.idx <- which(rownames(mat) == gene.id)
col.idx <- which(colnames(mat) %in% dplyr::filter(clusters.df,sample %in% chosen.samples())$cell)
gene.df <- suppressWarnings(dplyr::left_join(tsne.df %>% dplyr::filter(sample %in% chosen.samples()),data.frame(cell=colnames(mat)[col.idx],value=mat[row.idx,col.idx],stringsAsFactors=F),by=c("cell"="cell")))
scatter.plot <- plotly::plot_ly(marker=list(size=12),type='scatter',mode="markers",color=~gene.df$value,x=~gene.df$tSNE1,y=~gene.df$tSNE2,showlegend=F) %>%
plotly::layout(xaxis=list(title="tSNE1",zeroline=F,showticklabels=F),yaxis=list(title="tSNE2",zeroline=F,showticklabels=F))
scatter.plot
}
})
output$Embedding <- plotly::renderPlotly({
scatter.plot()
})
output$save <- downloadHandler(
filename = function() {
paste0(dplyr::filter(meta.df,symbol == input$symbol,gene_id == input$gene_id)$symbol,"_",dplyr::filter(meta.df,symbol == input$symbol,gene_id == input$gene_id)$gene_id,".pdf")
},
content = function(file) {
plotly::export(scatter.plot(),file=file)
}
)
}
ui <- fluidPage(
# App title ----
titlePanel("Results Explorer"),
# Sidebar layout with a input and output definitions ----
sidebarLayout(
# Sidebar panel for inputs ----
sidebarPanel(
# select samples
checkboxGroupInput("samples.choice", "Samples",choices = names(samples.choices),selected="all"),
# select gene symbol
selectInput("symbol", "Gene Symbol", choices = unique(meta.df$symbol)),
# select gene id
uiOutput("gene_id"),
# select plot type
selectInput("plot.type", "Plot Type", choices = c("tSNE","PCA")),
# save plot as html
downloadButton('save', 'Save as PDF')
),
# Main panel for displaying outputs ----
mainPanel(
# The plot is called Embedding and will be created in ShinyServer part
# plotOutput("Embedding")
plotly::plotlyOutput("Embedding")
)
)
)
shinyApp(ui = ui, server = server)
Hope it helps!

How to use ChartJS Radar Plot in shiny

I would like to use the chartJSRadar() instead of webplot() in the example below. Is it possible? I do not know the function of webplot() but I need to use a radar chart in this place. Use of this function starts with 33 lines. The code can also be found here: https://gist.github.com/mbannert/9124890/
data_sets <- c("mtcars")
shinyServer(function(input, output) {
# Drop-down selection box for which data set
output$choose_dataset <- renderUI({
selectInput("dataset", "Data set", as.list(data_sets))
})
# select a car
output$choose_car <- renderUI({
selectInput("car","car",as.list(rownames(get(input$dataset))))
})
# Check boxes
output$choose_columns <- renderUI({
# If missing input, return to avoid error later in function
if(is.null(input$dataset))
return()
# Get the data set with the appropriate name
dat <- get(input$dataset)
colnames <- names(dat)
# Create the checkboxes and select them all by default
checkboxGroupInput("columns", "Choose columns",
choices = colnames,
selected = colnames)
})
output$radar <- renderPlot({
source("radar.R")
webplot(get(input$dataset),
which(rownames(mtcars) == input$car), y.cols = input$columns,add=F)
})
# Output the data
output$data_table <- renderTable({
# If missing input, return to avoid error later in function
if(is.null(input$dataset))
return()
# Get the data set
dat <- get(input$dataset)
# Make sure columns are correct for data set (when data set changes, the
# columns will initially be for the previous data set)
if (is.null(input$columns) || !(input$columns %in% names(dat)))
return()
# Keep the selected columns
dat <- dat[, input$columns, drop = FALSE]
# Return first 20 rows
head(dat, 20)
})
})
shinyUI(pageWithSidebar(
headerPanel("Car Comparison Radar"),
sidebarPanel(
uiOutput("choose_dataset"),
uiOutput("choose_car"),
uiOutput("choose_columns"),
br(),
a(href = "http://statisticstoproveanything.blogspot.de/2013/11/spider-web-plots-in-r.html",
"Radar by Alan Vaughn from statisticstoproveanything"),
br(),
a(href = "https://gist.github.com/mbannert/9124890/",
"Find the shiny code gist here.")
),
mainPanel(
plotOutput(outputId = "radar", height = "600px"),
tableOutput("data_table")
)
))
There are some other warnings that the app is throwing that I didn't touch, but this works:
library(shiny)
library(chartjs)
data_sets <- c("mtcars")
shinyServer(function(input, output) {
# Drop-down selection box for which data set
output$choose_dataset <- renderUI({
selectInput("dataset", "Data set", as.list(data_sets))
})
# select a car
output$choose_car <- renderUI({
selectInput("car","car",as.list(rownames(get(input$dataset))))
})
# Check boxes
output$choose_columns <- renderUI({
# If missing input, return to avoid error later in function
if(is.null(input$dataset))
return()
# Get the data set with the appropriate name
dat <- get(input$dataset)
colnames <- names(dat)
# Create the checkboxes and select them all by default
checkboxGroupInput("columns", "Choose columns",
choices = colnames,
selected = colnames)
})
output$radar <- renderChartjs({
# Get the data set
dat <- get(input$dataset)
# Make sure columns are correct for data set (when data set changes, the
# columns will initially be for the previous data set)
if (is.null(input$columns) || !(input$columns %in% names(dat)))
return()
# Keep the selected columns
dat <- dat[, input$columns, drop = FALSE]
#row data for plot
car <- as.vector(t(dat[row.names(dat) == input$car,]))
chartjs() %>%
cjsRadar(labels = colnames(dat)) %>%
cjsSeries(data = car) %>%
cjsEditScale(axis = NULL, ticks = list(beginAtZero = TRUE))
})
# Output the data
output$data_table <- renderTable({
# If missing input, return to avoid error later in function
if(is.null(input$dataset))
return()
# Get the data set
dat <- get(input$dataset)
# Make sure columns are correct for data set (when data set changes, the
# columns will initially be for the previous data set)
if (is.null(input$columns) || !(input$columns %in% names(dat)))
return()
# Keep the selected columns
dat <- dat[, input$columns, drop = FALSE]
# Return first 20 rows
head(dat, 20)
})
})
shinyUI(pageWithSidebar(
headerPanel("Car Comparison Radar"),
sidebarPanel(
uiOutput("choose_dataset"),
uiOutput("choose_car"),
uiOutput("choose_columns"),
br(),
a(href = "http://statisticstoproveanything.blogspot.de/2013/11/spider-web-plots-in-r.html",
"Radar by Alan Vaughn from statisticstoproveanything"),
br(),
a(href = "https://gist.github.com/mbannert/9124890/",
"Find the shiny code gist here.")
),
mainPanel(
chartjsOutput(outputId = "radar", height = '75px'),
tableOutput("data_table")
)
))
OK, you could do it this way if you really want to stick with the radarchart library:
library(shiny)
library(radarchart)
data_sets <- c("mtcars")
shinyServer(function(input, output) {
# Drop-down selection box for which data set
output$choose_dataset <- renderUI({
selectInput("dataset", "Data set", as.list(data_sets))
})
# select a car
output$choose_car <- renderUI({
selectInput("car","car",as.list(rownames(get(input$dataset))))
})
# Check boxes
output$choose_columns <- renderUI({
# If missing input, return to avoid error later in function
if(is.null(input$dataset))
return()
# Get the data set with the appropriate name
dat <- get(input$dataset)
colnames <- names(dat)
# Create the checkboxes and select them all by default
checkboxGroupInput("columns", "Choose columns",
choices = colnames,
selected = colnames)
})
output$radar <- renderChartJSRadar({
# Get the data set
dat <- get(input$dataset)
# Make sure columns are correct for data set (when data set changes, the
# columns will initially be for the previous data set)
if (is.null(input$columns) || !(input$columns %in% names(dat)))
return()
# Keep the selected columns
dat <- dat[, input$columns, drop = FALSE]
#reform data for plot
dat <- as.data.frame(t(dat), stringsAsFactors = FALSE)
dat$labs <- row.names(dat)
dat <- dat[, c('labs', input$car)]
chartJSRadar(dat)
})
# Output the data
output$data_table <- renderTable({
# If missing input, return to avoid error later in function
if(is.null(input$dataset))
return()
# Get the data set
dat <- get(input$dataset)
# Make sure columns are correct for data set (when data set changes, the
# columns will initially be for the previous data set)
if (is.null(input$columns) || !(input$columns %in% names(dat)))
return()
# Keep the selected columns
dat <- dat[, input$columns, drop = FALSE]
# Return first 20 rows
head(dat, 20)
})
})
shinyUI(pageWithSidebar(
headerPanel("Car Comparison Radar"),
sidebarPanel(
uiOutput("choose_dataset"),
uiOutput("choose_car"),
uiOutput("choose_columns"),
br(),
a(href = "http://statisticstoproveanything.blogspot.de/2013/11/spider-web-plots-in-r.html",
"Radar by Alan Vaughn from statisticstoproveanything"),
br(),
a(href = "https://gist.github.com/mbannert/9124890/",
"Find the shiny code gist here.")
),
mainPanel(
chartJSRadarOutput('radar', height = '350px'),
#chartjsOutput(outputId = "radar", height = '75px'),
tableOutput("data_table")
)
))

Filtering dataframe rows from dynamic variables within shiny

I'm writing a shiny function that takes a dataset and generates UI components based upon the presence of design variables (factors) and response variables (numeric).
I would like to have a checkbox input to hide/show all of the variables in the app (the design UI element) and also be able to filter out particular rows based upon the levels of the design factors. Since the number of factors in a dataset is unknown, this has to be generated generically.
Within the function, before ui and server are defined, I find all of the factor variables and generate the relevant parameters for checkboxGroupInputs and then in ui use lapply and do.call to add them to the interface. However, I now need to use them to filter the rows and I'm not sure how to do so.
I've prepared a MWE to illustrate:
data(iris)
iris$Species2 <- iris$Species
filterex <- function(data = NULL){
library(shiny)
# Get design variables (factors) and response variables:
dvars <- names(which(sapply(data, class) == "factor"))
rvars <- names(which(sapply(data, class) != "factor"))
# Generate inputs for all design factor filters:
num_filters <- length(dvars)
filters <- list()
for (i in 1:num_filters){
filt <- dvars[[i]]
filters[[i]] <- list(inputId = filt, label = filt,
choices = levels(data[[filt]]),
selected = levels(data[[filt]]))
}
## UI #############################
ui = fluidPage(
titlePanel("Dynamic filtering example"),
sidebarPanel(
checkboxGroupInput(inputId = "design", label = "Design Variables",
choices = dvars, selected = dvars),
# Add filter checkboxes:
lapply(filters, do.call, what = checkboxGroupInput)),
mainPanel(
dataTableOutput("data"))
)
## SERVER #########################
server = function(input, output, session) {
# SUBSET DESIGN COLUMNS BASED UPON INPUTS:
dat_subset <- reactive({
df <- data[, c(input$design, rvars), drop = FALSE]
# NEED TO INCORPORATE CODE TO SUBSET ROWS HERE
return(df)
})
output$data <- renderDataTable({
dat_subset()
})
}
runApp(list(ui = ui, server = server))
}
filterex(iris)
My issues are:
[SOLVED] Even though it appears the filter checkboxes are being created (lines 11:19), I cannot get them to be included in the app as expected.
Once they are added, I'm not sure how to utilize them to filter the rows as needed around line 40 (e.g., should be able to uncheck setosa from Species to hide those rows).
Any advice would be really appreciated! I've looked at many other threads, but all the solutions I've come across are tailored for a particular dataset (so the number and names of the variables are known a priori).
Similar to your arrived solution, consider lapply over for loops in building filters and dynamic subsetting:
filterex <- function(data = NULL){
# Get design variables (factors) and response variables:
dvars <- names(which(sapply(data, class) == "factor"))
rvars <- names(which(sapply(data, class) != "factor"))
# Generate inputs for all design factor filters:
filters <- lapply(dvars, function(d) {
list(inputId = d, label = d,
choices = levels(data[[d]]),
selected = levels(data[[d]]))
})
## UI #############################
ui = fluidPage(
titlePanel("Dynamic filtering example"),
sidebarPanel(
checkboxGroupInput(inputId = "design", label = "Design Variables",
choices = dvars, selected = dvars),
# Add filter checkboxes:
lapply(filters, do.call, what = checkboxGroupInput)),
mainPanel(
dataTableOutput("data"))
)
## SERVER #########################
server = function(input, output, session) {
# SUBSET DESIGN COLUMNS BASED UPON INPUTS:
dat_subset <- reactive({
df <- data[, c(input$design, rvars), drop = FALSE]
# DF SUBSET LIST
dfs <- lapply(dvars, function(d) {
df[df[[d]] %in% input[[d]],]
})
# ROW BIND ALL DFs
df <- do.call(rbind, dfs)
return(df)
})
output$data <- renderDataTable({
dat_subset()
})
}
runApp(list(ui = ui, server = server))
}
filterex(iris)
If there is a better way of doing this, I would love to hear it but I have a working prototype! This can show/hide the design variables and filter the rows based upon the boxes that are checked/unchecked. Further, the UI elements for the filters are added/hidden based upon the design selection :)
filterex <- function(data = NULL){
# Get design variables (factors) and response variables:
dvars <- names(which(sapply(data, class) == "factor"))
rvars <- names(which(sapply(data, class) != "factor"))
data$internalid <- 1:nrow(data)
## UI #############################
ui = fluidPage(
titlePanel("Dynamic filtering example"),
sidebarPanel(
checkboxGroupInput(inputId = "design", label = "Design Variables",
choices = dvars, selected = dvars),
uiOutput("filters")),
mainPanel(
dataTableOutput("data"))
)
## SERVER #########################
server = function(input, output, session) {
# Determine checkboxes:
output$filters <- renderUI({
filters <- lapply(dvars[dvars == input$design], function(d) {
list(inputId = d, label = d,
choices = levels(data[[d]]),
selected = levels(data[[d]]))
})
lapply(filters, do.call, what = checkboxGroupInput)
})
# GENERATE REDUCED DATA TABLE:
dat_subset <- reactive({
# SUBSET DATA BY DESIGN INPUTS
df <- data[, c(input$design, rvars, "internalid"), drop = FALSE]
# SUBSET DATA BY ROWS AND MERGE
for (i in 1:length(input$design)){
if(!is.null(input[[input$design[[i]]]])){
dfs <- lapply(input$design, function(d) {
df[df[[d]] %in% input[[d]],]
})
if (length(dfs) > 1){
df <- Reduce(function(...) merge(..., all=FALSE), dfs)
} else df <- dfs[[1]]
}
}
return(df)
})
output$data <- renderDataTable({
dat_subset()[,c(input$design, rvars)]
})
}
runApp(list(ui = ui, server = server), launch.browser = TRUE)
}
data(iris)
iris$Species2 <- iris$Species
filterex(iris)
Here is one option using tidyverse
library(shiny)
library(dplyr)
library(purrr)
filterex <- function(data = NULL) {
i1 <- data %>%
summarise_all(is.factor) %>%
unlist()
dvars <- i1 %>%
names(.)[.]
rvars <- i1 %>%
`!` %>%
names(.)[.]
filters <-dvars %>%
map(~list(inputId = .,
label = .,
choices = levels(data[[.]]),
selected = levels(data[[.]])))
ui = fluidPage(
titlePanel("Dynamic filtering example"),
sidebarPanel(
checkboxGroupInput(inputId = "design",
label = "Design Variables",
choices = dvars,
selected = dvars),
map(filters, ~do.call(what = checkboxGroupInput, .))),
mainPanel(dataTableOutput("data"))
)
server = function(input, output, session) {
dat_subset <- reactive({
df <- data %>%
select(input$design, rvars)
dvars %>%
map2_df(list(df), ~.y %>%
filter_at(.x, all_vars(. %in% input[[.x]])))
})
output$data <- renderDataTable({
dat_subset()
})
}
runApp(list(ui = ui, server = server))
}
Using the function on 'iris'
filterex(iris)
Output got is

Shiny R - reactivity not working with conditional panel

Problem :
In my app I have two tabs in the side panel
Stats and Charts -
In stats I want to show the data frame and some descriptive stats (which works fine) based on the Data thats is being selected in main panel (select input which selects the Data) and selectGroupinput( which selects the columns of the selected data) ,
in Charts I have a drop down of the columns of the selected Data and want to show bar charts for them .
Now this works smoothly when I dont put a conditional panel for selectgroupinput to be shown only in the Stat Tab and Drop down selectinput only in the Chart tab ( in the sense that the columns automatically gets updated when selecting a Data .
Now when I put conditional panel around that ,it works smooth for the Stat tab but in Charts tab the the Columns does not function properly on changing the data set .
I have to click the Stat tab and again click back to Charts tab to make the actual columns of the data appear in the drop down -in short the reactivity of the Data set and Column drop down is not functioning as it should be .
I have a reproducible code sample here :
https://gist.github.com/creepystranger/9168c1430c7d468fc5fb
code :
server.r
ibrary(shiny)
#library(RODBC)
library(ggplot2)
#library(shinyjs)
#stat_helper_function to be used in rendering stat table
summary <- function(x) {
funs <- c(mean, median, sd, mad, IQR,max,min)
lapply(funs, function(f) f(x, na.rm = TRUE))
}
make_stat <- function(data){
numeric_columns <- sapply(data,is.numeric)
stat_table <- sapply(data[,numeric_columns],summary)
rows <- c("Mean","Median","SD","MAD","IQR","Max","Min")
df <- data.frame(stat_table,row.names = rows)
}
#sample prototypeof Data
data_sets <- c("iris","diamonds")
shinyServer(function(input, output) {
output$choose_dataset <- renderUI({
selectInput("Dataset",label = "choose a dataset",as.list(data_sets))
})
output$choose_columns <- renderUI({
if(is.null(input$Dataset))
return()
dat <<- get(input$Dataset) # make it globally accessable _saves the pain of multiple load of the data
colnames <- names(dat)
checkboxGroupInput("columns", "Choose columns",
choices = colnames,
selected = colnames)
})
output$plot_control <- renderUI({
if(is.null(input$Dataset))
return()
dat #<- get(input$Dataset)
numeric_columns <- sapply(dat,is.numeric)
num_dat <- dat[,numeric_columns]
colnames <- names(num_dat)
selectInput("selectize","For the X axis and Y axis",choices=colnames)
})
output$histo_gram <- renderPlot({
if(is.null(input$Dataset))
return()
#z<- matrix(num_dat,ncol = ncol(num_dat))
numeric_columns <- sapply(dat,is.numeric)
num_dat <- dat[,numeric_columns]
num_dat
if (is.null(input$selectize) || !(input$selectize %in% names(num_dat)))
return()
z <- num_dat[,input$selectize]
# bw <- diff(range(z)) / (2 * IQR(z) / length(z)^(1/3))
qplot(z,geom ="histogram")
})
output$mytable1 <- renderDataTable({
if(is.null(input$Dataset))
return()
#dat <- get(input$Dataset)
dat
if (is.null(input$columns) || !(input$columns %in% names(dat)))
return()
# Keep the selected columns
dat <- dat[, input$columns, drop = FALSE]
dat}, options=list(lengthMenu = c(5, 8, 10), pageLength = 5)
)
output$stat_table <- renderTable({
dat #<- get(input$Dataset)
num_dat <- dat[,input$columns,drop=FALSE]
make_stat(num_dat)
}
)
})
ui.r
# This is the user-interface definition of a Shiny web application.
# You can find out more about building applications with Shiny here:
#
# http://www.rstudio.com/shiny/
#
library(shiny)
library(ggplot2)
shinyUI (pageWithSidebar(
headerPanel("Creepy-Stats"),
sidebarPanel(
uiOutput("choose_dataset"),
br(),
conditionalPanel(
condition ="input.conditionedPanels == 'Stats'",uiOutput("choose_columns")),
conditionalPanel(condition ="input.conditionedPanels == 'Charts'" ,uiOutput("plot_control")), width = 2
#
# uiOutput("choose_columns"),uiOutput("plot_control"),width = 2
),
mainPanel(
tabsetPanel(
tabPanel("Stats",
div (class='row',
div(dataTableOutput("mytable1"),class="span10"),
div(tableOutput("stat_table"),class="span5")
),id = "conditionedPanels"
)
,
tabPanel("Charts",
div(class='row',
div(plotOutput("histo_gram"),class="span10"))
),id = "conditionedPanels"
),width = 10
)
))

Resources