How to use ChartJS Radar Plot in shiny - r

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")
)
))

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)
})

Shiny: How to merge and abbreviate inputs to extract data from excel sheet?

I am trying to set up an entry mask for users to enter distinct inputs in two fields that in turn extract data from an external excel sheet. The two input fields are Geography and World Region. There are several options to pick from for both fields, i.e. Africa or United States for Geography. The user can add as many input rows as he would like. The excel sheet that runs in the background has multiple columns, one for each possible combination of inputs that the user can select. Each column is named as a combined character string of the two abbreviations of the possible input options and has data in it that should be extracted and used later on.
Once the user has submitted their data, the string of characters made up of the two abbreviations should be produced for each input row so that it can be used to extract the data out of the respective column in the excel sheet. E.g if in the first input row the user has selected "Africa" and "Region1" the data of the column "Afr_Em" should be used. This should happen for each row of input the user indicates.
Right now, I am trying to store the abbreviations of the two fields in InputList to use this later to extract the data but it does not seem to work.
Here is my code so far:
# library(packages,etc.)
GeographyList <- c("Africa"="Afr",
"Asia"="AS",
"Europe"="EU")
WorldRegionList <- c("Region1"="Em",
"Region2"="Dev")
ui <- fluidPage(#....design etc.,
# this is just a demo to show the input values
mainPanel(
uiOutput("inputwidgets"),
actionButton('number',
'Add row'),
actionButton('delete_number',
'Delete row'),
actionButton("update", "Update View"),
h4("allocation"),
plotOutput("allocation"),
textOutput("labels"))
)
server <- function(input, output) {
# (For remove button) Reactive value that is triggered by add and remove button
reac <- reactiveValues()
observeEvent(c(input$number,input$delete_number), {
# you need to add 1 to not start with 0
add <- input$number+1
# restriction for delete_number > number
delete <- if(input$delete_number > input$number) add else input$delete_number
calc <- add - delete
reac$calc <- if(calc > 0) 1:calc else 1
})
# Get new input by clicking Add Row
observe({
req(reac$calc)
output$inputwidgets = renderUI({
input_list <- lapply(reac$calc, function(i) {
Geography <- input[[paste0("Geography",i)]]
Region <- input[[paste0("WorldRegion",i)]]
amount <- input[[paste0("amount",i)]]
fluidRow(
column(2,
selectInput(paste0("Geography", i),
label = paste0("Geography", i),
choices = GeographyList,
multiple = FALSE,
selected = if(!is.null(Geography)) Geography)
),
column(3,
selectInput(paste0("WorldRegion", i),
label = paste0("World Region", i),
choices = WorldRegionList,
multiple = FALSE,
selected = if(!is.null(Region)) Region)),
column(3,
# Input: Specify the amount ----
numericInput(
paste0("amount",i),
label="Amount",
value = if(!is.null(amount)) amount else 0
)
)
)
})
do.call(tagList, input_list)
})
})
# List with the desired abbreviations, 1 abbreviation for each row
InputList <- eventReactive(input$update,{
lapply(1:input$number, function(i) {
paste0(eval(parse(text=paste0("input$Geography",i))),"_",eval(parse(text=paste0("input$WorldRegion",i))))
})})
output$labels <- renderText({ paste0(InputList()) })
# List with the desired abbreviations, 1 abbreviation for each row
allocation <- eventReactive(input$update, {
x <- c(input$amount1, input$amount2, input$amount3)
lbls <- c(paste0(InputList()))
pie(x, labels = lbls)
})
output$allocation <- renderPlot({
if (input$update == 0)
return()
(allocation())
})
}
# Create Shiny app ----
shinyApp(ui = ui, server = server)
and this is basically how the excel sheet looks like (at least partly, adding all possible combinations of abbreviations would be too much but I hope you understand the structure):
Afr_EM Afr_EM Afr_EM ... LAC_Dev
5 5 3 ... 7
3 1 2 ... 8
...
As I am very new to shiny, I would appreciate any kind of help!
Please test the below:
GeographyList <-list("Africa"="Afr",
"Asia"="AS",
"Europe"="EU")
WorldRegionList <- list("Region1"="Em",
"Region2"="Dev")
ui <- fluidPage(#....design etc.,
# this is just a demo to show the input values
mainPanel(
uiOutput("inputwidgets"),
actionButton('number',
'Add row'),
# Input: Click to run input
actionButton("update", "Run")))
server <- function(input, output) {
# By clicking the actionButton an additional row appears
observeEvent(input$number, {
output$inputwidgets = renderUI({
input_list <- lapply(1:input$number, function(i) {
fluidRow(
column(2,
selectInput(paste0("Geography", i),
label = paste0("Geography", i),
choices = GeographyList,
multiple = FALSE,
selected = NA)
),
column(3,
selectInput(paste0("WorldRegion", i),
label = paste0("World Region", i),
choices = WorldRegionList,
multiple = FALSE,
selected = NA)
))
})
do.call(tagList, input_list)
})
})
# List with the desired abbreviations, 1 abbreviation for each row
InputList <- eventReactive(input$update,{
lapply(1:input$number, function(i) {
paste0(eval(parse(text=paste0("input$Geography",i))),"_",eval(parse(text=paste0("input$WorldRegion",i))))
})})
}
# Create Shiny app ----
shinyApp(ui = ui, server = server)
I have created the 2 lists at the beginning as actual named lists. This removes the need for your switch see here by choices. I don't have the full code but it seems to be working from what I can see.
I have figured it out with the help of #Eli Berkow.
When including an action button to delete rows, I need to replace input$number in the InputList function with tail(reac$calc, n=1) to fetch the number of rows used.
Here is my full code:
# library(packages,etc.)
GeographyList <- c("Africa"="Afr",
"Asia"="AS",
"Europe"="EU")
WorldRegionList <- c("Region1"="Em",
"Region2"="Dev")
ui <- fluidPage(#....design etc.,
# this is just a demo to show the input values
mainPanel(
uiOutput("inputwidgets"),
actionButton('number',
'Add row'),
actionButton('delete_number',
'Delete row'),
actionButton("update", "Update View"),
h4("allocation"),
plotOutput("allocation"),
textOutput("labels"))
)
server <- function(input, output) {
# (For remove button) Reactive value that is triggered by add and remove button
reac <- reactiveValues()
observeEvent(c(input$number,input$delete_number), {
# you need to add 1 to not start with 0
add <- input$number+1
# restriction for delete_number > number
delete <- if(input$delete_number > input$number) add else input$delete_number
calc <- add - delete
reac$calc <- if(calc > 0) 1:calc else 1
})
# Get new input by clicking Add Row
observe({
req(reac$calc)
output$inputwidgets = renderUI({
input_list <- lapply(reac$calc, function(i) {
Geography <- input[[paste0("Geography",i)]]
Region <- input[[paste0("WorldRegion",i)]]
amount <- input[[paste0("amount",i)]]
fluidRow(
column(2,
selectInput(paste0("Geography", i),
label = paste0("Geography", i),
choices = GeographyList,
multiple = FALSE,
selected = if(!is.null(Geography)) Geography)
),
column(3,
selectInput(paste0("WorldRegion", i),
label = paste0("World Region", i),
choices = WorldRegionList,
multiple = FALSE,
selected = if(!is.null(Region)) Region)),
column(3,
# Input: Specify the amount ----
numericInput(
paste0("amount",i),
label="Amount",
value = if(!is.null(amount)) amount else 0
)
)
)
})
do.call(tagList, input_list)
})
})
# List with the desired abbreviations, 1 abbreviation for each row
InputList <- eventReactive(input$update,{
lapply(1:tail(reac$calc, n=1), function(i) {
paste0(eval(parse(text=paste0("input$Geography",i))),"_",eval(parse(text=paste0("input$WorldRegion",i))))
})})
output$labels <- renderText({ paste0(InputList()) })
# List with the desired abbreviations, 1 abbreviation for each row
allocation <- eventReactive(input$update, {
x <- c(input$amount1, input$amount2, input$amount3)
lbls <- c(paste0(InputList()))
pie(x, labels = lbls)
})
output$allocation <- renderPlot({
if (input$update == 0)
return()
(allocation())
})
}
# Create Shiny app ----
shinyApp(ui = ui, server = server)

How to use a reactive variable in server Shiny

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)

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!

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