I am developing a shiny app. which selects nominal (factors) and ordinal(numeric) variables for a given dataset. Then it transform nominal variable(s) (male,female) to dummy variable(s). And eventually merges ordinal variables with dummy variables. The app works fine if I select both nominal and ordinal variables. But if I only want to choose nominal OR ordinal variables,I get warnings: "No character or factor columns found. Please use select_columns to choose columns." Here are my server.r and ui.R
library(fastDummies)
library(data.table)
data=data.frame(A=c(5,2,4),B=c('male','male','female'),C=c(1,3,5))
shinyServer(
function(input, output){
#Select Explanatory Nominal Variables
output$ColumnSelector_dummy <- renderUI({
selectInput("SelectedDummy","Select Nominal Variables (values: male,female)",
choices = as.list(names(data)),multiple=TRUE, selected = NULL)
})
#
df_subset_dummy <- reactive({
a <- subset(data, select = input$SelectedDummy)
return(a)
})
#Convert Nominal variables to Dummy variables
df_subset_dummy_tranformed <- reactive({
df1 <- lapply( df_subset_dummy(), factor)
df2 <- fastDummies::dummy_cols(df1)
drops <- names(df1)
df3 <- df2[, !(names(df2) %in% drops)]
return(df3)
})
#Select Explanatory Ordinal Variables
output$ColumnSelector_ordinal<- renderUI({
selectInput("SelectedOrdinal","Select Ordinal Variables (values: 1,2,3,4,5,6)",
choices = as.list(names(data)), multiple=TRUE,selected = NULL )
})
df_subset_ordinal <- reactive({
a <- subset(data, select = input$SelectedOrdinal)
return(a)
})
#Join Ordinal and Nominal dataframes
df_nominal_ordinal_bind <- reactive({
df <- cbind(df_subset_dummy_tranformed(),df_subset_ordinal())
return(df)
})
output$table_ordinal_nominal <- renderTable(head(df_nominal_ordinal_bind()))
})
shinyUI(
fluidPage(
tabsetPanel(
tabPanel("Data", fluid = TRUE,
sidebarLayout(
sidebarPanel(
uiOutput("ColumnSelector_dummy"),
uiOutput("ColumnSelector_ordinal")
),
mainPanel(
tabsetPanel(
tabPanel('Subsets',
tableOutput('table_ordinal_nominal')
) )) ) ))))
question: How can I use tryCatch and if/else blockes, so that if df_subset_dummy_tranformed() OR df_subset_ordinal() does not exist, I still get result for df_nominal_ordinal_bind and it also can be shown as a table in output$table_ordinal_nominal. Any help would be appreciated.
Without changing your code / approach too much, I guess you could start by adding a check on df_subset_dummy():
df_subset_dummy_tranformed <- reactive({
res <- df_subset_dummy()
if (length(res) == 0) return(res)
df1 <- lapply(res, factor)
df2 <- fastDummies::dummy_cols(df1)
drops <- names(df1)
df3 <- df2[, !(names(df2) %in% drops)]
return(df3)
})
At least this should address the warning you mention.
Related
I am new to r and shinny, and can't figure out how to fix my code. I have 2 dfs (df and historical), and I filter the df to display results selected from SelectInput (col, and col2, "Market" and "Month"). At the same time, I want to filter historical by the same values choosen for "Market" and "Month", and display below the table, a histogram of the filtered price_vector - that is, "average_price" from "historical" but filtered by chosen "Market" and "Month".
Any feedback is appreciated, and by the way, if you have a solution that uses reticulate, I dont mind it (no problem for me filtering a df using python/pandas, but I am teaching myself shinny and can't figure this out)
library(shiny)
library(reticulate)
df <- read.csv(file = 'scores.csv')
historical <- read.csv('TRAIN.csv')
price_vector <- historical$average_price
lmkt <- unique(df$market)
mth <- unique(df$month)
ui <- fluidPage(
selectInput('col','Market',lmkt),
selectInput('col2','Month',mth),
dataTableOutput('table')
)
server <- function(input,output)
output$table <- renderDataTable({
df <- df
{
df = df[df[["market"]] == input$col,]
df = df[df[["month"]] == input$col2,]
}
})
shinyApp(ui = ui, server = server)
You can combine the two statements into one using & operator.
df <- read.csv('https://raw.githubusercontent.com/lmsanch/pyABS/master/scores.csv')
historical <- read.csv('https://raw.githubusercontent.com/lmsanch/pyABS/master/TRAIN.csv')
price_vector <- historical$average_price
lmkt <- unique(df$market)
mth <- unique(df$month)
ui <- fluidPage(
selectInput('col','Market',lmkt),
selectInput('col2','Month',mth),
dataTableOutput('table'),
plotOutput('plot')
)
server <- function(input,output) {
output$table <- renderDataTable({
df[df$market == input$col & df$month == input$col2, ]
})
output$plot <- renderPlot({
hist(price_vector[df$market == input$col & df$month == input$col2])
})
}
shinyApp(ui, server)
I have an R dataframe with several columns and I'd like users to select one column to plot against time. However, when I try to run this code, I get an error message.
country <- reactive({
input$variable
})
date_start <- reactive({
input$dateRange[1]
})
date_end <- reactive({
input$dateRange[2]
})
new_data <- reactive({
data[which(data$location== country() & data$date >= date_start() & data$date<=date_end()),c("date","location",input$info)]
names(new_data()) <- c("date", "location", "col1")
})
The error is:
Error in names(new_data()) <- c("date", "location", "col1") :
invalid (NULL) left side of assignment
Can anyone help me with that, please?
This should do the trick:
new_data <- reactive({
data_selection <- data[which(data$location== country() & data$date >= date_start() & data$date<=date_end()),c("date","location",input$info)]
colnames(data_selection) <- c("date", "location", "col1")
data_selection
})
You were referencing the reactive value inside the reactive call, which is then assigned to the new_data. Because this happens before the assignment, the value of the new_data within the call is null. Fortunately there is no need to do that.
Note: as you didn't post your data, I had no way to actually test your code.
However here is a minimal working example to illustrate the concept:
library(shiny)
ui <- fluidPage(
dataTableOutput("geysers")
)
server <- function(input, output) {
test <- reactive({
a <- faithful[1:3,]
colnames(a) <- c("a", "b")
a
})
output$geysers <- renderDataTable({test()})
}
shinyApp(ui = ui, server = server)
I'm making a Shiny app in which the user can generate a column in a table by clicking on a checkboxInput. The column I would like to create contains the lagged value of the column already present in the table.
The code below shows a reproducible example: there are two individuals (A and B) and three time periods (1, 2 and 3).
library(dplyr)
library(shiny)
data <- head(mtcars)
data$time <- rep(seq(1:3))
data$ID <- rep(c("A", "B"), each = 3)
ui <- fluidPage(
selectInput("choice", "Select a column", choices = c("mpg", "drat", "hp"), multiple = F),
checkboxInput("lag", "Compute lag value"),
tableOutput("table")
)
server <- function(input, output, session) {
data2 <- reactive({
lagged_name <- paste0(input$choice, "_lagged")
if (input$lag){
data %>%
select(ID, time, input$choice) %>%
group_by(ID) %>%
mutate(!!all_of(lagged_name) := lag(data[, input$choice]))
}
else {
data %>%
select(ID, time, input$choice)
}
})
output$table <- renderTable({
data2()
})
}
shinyApp(ui, server)
When I run this code and click on the checkbox, I have the error:
Warning: Error in : Column mpg_lagged must be length 3 (the group size) or one, not 6
Thanks to this answer, I corrected it by adding order_by = ID in the lag function but now there is another problem: for individual 1, it creates the right lagged values, but then those values are repeated for individual 2 as well whereas they do not correspond.
I tried a similar example without the Shiny environment and the right output is produced so I suppose this problem comes from the inputs or reactive environment.
Does anybody have a solution?
There are some (minor) issues with non-standard evaluation (NSE) inside your reactive data object. Fixing these gives
library(dplyr)
library(shiny)
data <- head(mtcars)
data$time <- rep(seq(1:3))
data$ID <- rep(c("A", "B"), each = 3)
ui <- fluidPage(
selectInput("choice", "Select a column", choices = c("mpg", "drat", "hp"), multiple = F),
checkboxInput("lag", "Compute lag value"),
tableOutput("table")
)
server <- function(input, output, session) {
data2 <- reactive({
lagged_name <- paste0(input$choice, "_lagged")
if (input$lag){
data %>%
select(ID, time, input$choice) %>%
group_by(ID) %>%
mutate(!!lagged_name := lag(!!sym(input$choice)))
}
else {
data %>%
select(ID, time, input$choice)
}
})
output$table <- renderTable({
data2()
})
}
shinyApp(ui, server)
resulting in
Explanation:
select takes both evaluated symbols and strings as arguments, so we can directly pass input$choice as an argument to select.
To construct a new column with a name from a variable we need to evaluate the variable as !!lagged_name; we then must use := (instead of =) to do the assignment, as R's grammar does not allow expressions as argument names (the lhs of the assignment). Finally, inside the lag function we first must convert input$choice to a symbol with sym and then evaluate the symbol with !!. That's because of dplyr's NSE, where you would write e.g. mtcars %>% mutate(col = lag(wt)) and not mtcars %>% mutate(col = lag("wt")).
I have a single-cell gene x cell expression data that I'd like to explore using a shiny app. The cells come from samples and are clustered according to a prior clustering run.
Here is a toy example data set:
suppressPackageStartupMessages(library(dplyr))
suppressPackageStartupMessages(library(plotly))
suppressPackageStartupMessages(library(shiny))
set.seed(1)
mat <- matrix(rnorm(1000*1000),nrow=1000,dimnames = list(paste0("gene",1:1000),paste0("cell",1:1000)))
meta.df <- data.frame(cell=colnames(mat),
sample=sample(paste0("sample",1:10),1000,replace=T),
cluster=sample(paste0("cluster",1:5),200,replace=T),
stringsAsFactors = F)
There are two functionalities that I'd like to enable:
View the tSNE 2D embedding of the entire data allowing to choose a gene where the points in the tSNE 2D embedding scatter plot will be colored by its expression values.
Be able to select a specific set of genes and clusters and/or samples on which tSNE will be re-run, and again view this 2D embedding coloring the points according to the expression levels of a chosen gene (in this case obviously the selection options is subsetted to be one of the selected genes).
Here's the tSNE embedding on all the data:
all.data.tsne.df <- data.frame(Rtsne::Rtsne(t(mat))$Y) %>%
rename(tSNE1=X1,tSNE2=X2) %>% cbind(meta.df)
For the second functionality, since one might like to color code many genes using the same tSNE embedding, and since a Rtsne run can take a while to run, I thought I'd save any gene and cell subset tSNE embedding in a list named by the chosen genes and cells, and always check if this subset already exists before running the Rtsne on it.
So at the top of the shiny code I create the options for subsetting samples and clusters and an empty tSNE list:
samples <- c("all",unique(meta.df$sample))
samples.choices <- 1:length(samples)
names(samples.choices) <- samples
clusters <- c("all",unique(meta.df$cluster))
clusters.choices <- 1:length(clusters)
names(clusters.choices) <- clusters
color.vec <- c("lightgray","darkred")
subset.tsne.map <- NULL
Here's my server 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
})
chosen.clusters <- reactive({
validate(
need(input$clusters.choice != "",'Please choose at least one of the cluster checkboxes')
)
clusters.choice <- input$clusters.choice
if("all" %in% clusters.choice) clusters.choice <- clusters[-which(clusters == "all")]
clusters.choice
})
output$gene <- renderUI({
if(input$plotType == "Gene-Subset tSNE"){
selectInput("gene", "Color by Gene", choices = unique(input$subset.genes))
} else{
selectInput("gene", "Color by Gene", choices = rownames(mat))
}
})
scatter.plot <- reactive({
if(!is.null(input$gene)){
row.idx <- which(rownames(mat) == input$gene)
col.idx <- which(colnames(mat) %in% filter(meta.df,cluster %in% chosen.clusters(),sample %in% chosen.samples())$cell)
#col.idx <- which(colnames(mat) %in% filter(meta.df,cluster %in% "cluster4",sample %in% unique(meta.df$sample))$cell)
if(input$plotType != "Gene-Subset tSNE"){
# subset of data
gene.tsne.df <- left_join(all.data.tsne.df %>% filter(cluster %in% chosen.clusters(),sample %in% chosen.samples()),data.frame(cell=colnames(mat)[col.idx],value=mat[row.idx,col.idx]),by=c("cell"="cell"))
scatter.plot <- plot_ly(marker=list(size=6),type='scatter',mode="markers",color=~gene.tsne.df$value,x=~gene.tsne.df$tSNE1,y=~gene.tsne.df$tSNE2,showlegend=F,colors=colorRamp(color.vec)) %>%
layout(xaxis=list(title="tSNE1",zeroline=F,showticklabels=F),yaxis=list(title="tSNE2",zeroline=F,showticklabels=F)) %>%
colorbar(limits=c(min(gene.tsne.df$value,na.rm=T),max(gene.tsne.df$value,na.rm=T)),len=0.4,title="Expression")
break
} else{
subset.genes <- sort(unique(input$subset.genes))
subset.row.idx <- which(rownames(mat) %in% subset.genes)
if(!is.null(subset.tsne.map)){
idx <- which(names(subset.tsne.map) == paste0(paste(subset.row.idx,collapse="_"),":",paste(col.idx,collapse="_")))
if(length(idx) > 0){
subset.tsne.df <- subset.tsne.map[[idx]] %>% mutate(value=mat[row.idx,col.idx])
scatter.plot <- plot_ly(marker=list(size=6),type='scatter',mode="markers",color=~subset.tsne.df$value,x=~subset.tsne.df$tSNE1,y=~subset.tsne.df$tSNE2,showlegend=F,colors=colorRamp(color.vec)) %>%
layout(xaxis=list(title="tSNE1",zeroline=F,showticklabels=F),yaxis=list(title="tSNE2",zeroline=F,showticklabels=F)) %>%
colorbar(limits=c(min(subset.tsne.df$value,na.rm=T),max(subset.tsne.df$value,na.rm=T)),len=0.4,title="Expression")
}
} else{
subset.tsne.df <- data.frame(t(mat[subset.row.idx,col.idx]),cell=colnames(mat)[col.idx]) %>% left_join(meta.df %>% filter(cell %in% colnames(mat)[col.idx]) %>% select(cell,cluster),by=c("cell"="cell"))
tsne.perplexity <- 10*length(subset.row.idx)
while(tsne.perplexity >= 1){
set.seed(1)
tsne.obj <- try(Rtsne::Rtsne(subset.tsne.df %>% select(-cell,-cluster),perplexity=tsne.perplexity),silent=T)
if(class(tsne.obj)[1] != "try-error"){
subset.tsne.df <- cbind(subset.tsne.df,data.frame(tsne.obj$Y) %>% rename(tSNE1=X1,tSNE2=X2))
subset.tsne.map[[length(subset.tsne.map)+1]] <- subset.tsne.df
names(subset.tsne.map)[length(subset.tsne.map)] <- paste0(paste(subset.row.idx,collapse="_"),":",paste(col.idx,collapse="_"))
subset.tsne.df <- subset.tsne.df %>% mutate(value=mat[row.idx,col.idx])
scatter.plot <- plot_ly(marker=list(size=6),type='scatter',mode="markers",color=~subset.tsne.df$value,x=~subset.tsne.df$tSNE1,y=~subset.tsne.df$tSNE2,showlegend=F,colors=colorRamp(color.vec)) %>%
layout(xaxis=list(title="tSNE1",zeroline=F,showticklabels=F),yaxis=list(title="tSNE2",zeroline=F,showticklabels=F)) %>%
colorbar(limits=c(min(subset.tsne.df$value,na.rm=T),max(subset.tsne.df$value,na.rm=T)),len=0.4,title="Expression")
} else{
tsne.perplexity <- tsne.perplexity-2
}
}
}
}
scatter.plot
}
})
output$Embedding <- renderPlotly({
scatter.plot()
})
output$save <- downloadHandler(
filename = function() {
paste0("../shiny/",input$gene,".",input$plotType,".pdf")
},
content = function(file) {
plotly::export(scatter.plot(),file=file)
}
)
}
And here's my UI code:
ui <- fluidPage(
# App title ----
titlePanel("Results Explorer"),
# Sidebar layout with a input and output definitions ----
sidebarLayout(
# Sidebar panel for inputs ----
sidebarPanel(
## custom CSS for 3 column layout (used below for mechanics filter options)
tags$head(
tags$style(HTML(".multicol {-webkit-column-count: 3; /* Chrome, Safari, Opera */-moz-column-count: 3; /* Firefox */column-count: 3;}"))),
## use the css, assuming your long list of vars comes from global.R
wellPanel(tags$div(class="multicol",checkboxGroupInput("samples.choice", "Samples",choices = names(samples.choices),selected="all"))),
wellPanel(tags$div(class="multicol",checkboxGroupInput("clusters.choice", "Clusters",choices = names(clusters.choices),selected="all"))),
# select plot type
selectInput("plotType", "Plot Type", choices = c("tSNE","Gene-Subset tSNE")),
#in case Gene Subset tSNE was chose select the genes
conditionalPanel(condition="input.plotType=='Gene-Subset tSNE'",
selectizeInput(inputId="subset.genes",label="Subset Genes for tSNE",choices=rownames(mat),selected=rownames(mat)[1],multiple=T)),
# select gene
uiOutput("gene"),
# 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
plotlyOutput("Embedding")
)
)
)
shinyApp(ui = ui, server = server)
It doesn't seem to be updating subset.tsne.map and each gene that is selected, even for the same sets of cells and genes, it run Rtsne again.
Is it possible to update subset.tsne.map with previously selected subsets at all? and if so am I doing it correctly?
i have the code as below and trying to plot gvisBarChart using the data selected from the drop down. the Server.r and ui.r code is given below
#server.r
shinyServer(function(input, output, session) {
output$ShowdataColDropDown <- renderUI({
df <-filedata()
if (is.null(df)) return(NULL)
#Let's only show numeric columns
nums <- sapply(df, is.numeric)
numitems=names(nums[nums])
selectizeInput("VarData", "Select Data:",c("", numitems()), multiple=TRUE, options = list(maxItems = 2,placeholder = 'select x and y parameters'))
})
output$ShowdataCatDropDown <- renderUI({
df <-filedata()
#Let's only show numeric columns
nums <- sapply(df, is.numeric)
numitems=names(nums[nums])
names(numitems)=numitems
selectInput("charData", "Select Data:",c("", numitems), selected=numitems[1])
})
output$myplot<-renderGvis({
#data
filedata <- data.frame(product=c("A","A","A","B","B"),Sales= c(10,3,4,2,20))
dfall<-data.frame(cbind(filedata[input$VarData],filedata[input$charData]))
#input$VarData is the input selected by the user for say 'sales'
#input$charDatais the input selected by the user for say 'product'
#The barchart code below is not working; Getting the error as: arguments must have same length
gvisBarChart(aggregate(dfall, list(dfall[input$charData]),mean))
})
}
#UI.r
shinyUI(
fluidPage(
uiOutput("ShowdataColDropDown"),
uiOutput("ShowdataCatDropDown"),
htmloutput("myplot")
)
please help me to dusplay the chart using mean(sales) by product.