Using an IF statement on a reactive variable inside an observe context - r

I am trying to create a shiny flexdashboard within R Markdown that will display different tables based on user input. Some tables are formattable, others are just regular tables. The following code will do the rendering of the table if the tables in a list are all Formattables.
num <- reactive(as.integer(input$qualityDataNum))
renderFormattable(qualityData[[num()]])
But since some are not formattables, I want to check before doing the render. Instead of putting the tables in a list I created the following code to pick the table based on user input. It doesn't work, I get a warning: "Error in if: argument is of length zero".
num <- reactive(as.integer(input$qualityDataNum))
observe({
if (num() == 1) {
renderFormattable(qualityData1)
} else {
renderTable(qualityData2)
}
})
The complete code is below (since this is RMarkdown code it was reformated when
the three ticks were used for code marking. Sorry.):
title: "Dashboard Prototype"
output: flexdashboard::flex_dashboard
runtime: shiny
# allow sharing of dashboard
library(datasets)
library(flextable)
library(formattable)
library(dplyr)
options(stringsAsFactors = FALSE)
qData <- data.frame(Name = "AAA", Releases = 10, Coverage = 23.0)
qData <- bind_rows(qData, data.frame(Name = "BBB", Releases = 35, Coverage = 88.0))
#Using Formattable
data_formatter_dd <-
formattable::formatter("span", style = x ~ style( font.weight = "bold",
color = ifelse(x > 80.0 & x <= 100.0, "green", ifelse(x > 50.0 & x <= 80.0, "orange", "red"))))
qualityData1 <- formattable::formattable(qData, align = c("l", rep("r", ncol(qData) - 1)),
list('Name' = formattable::formatter("span", style = ~ style(color = "grey", font.weight = "bold")),
'Coverage' = data_formatter_dd))
#Using flextable
qualityData2 <- flextable(head(qData, col_keys = c("Name", "Releases", "Coverage")))
Sidebar {.sidebar}
# shiny inputs
selectInput("qualityDataNum", label = h3("Quality Number Set"), choice = list("1" = 1, "2" = 2),
selected = 1)
Quality Statistics
Quality
num <- reactive(as.integer(input$qualityDataNum))
observe({
req(num())
if (num() == 1) {
renderFormattable(qualityData1)
} else {
renderTable(qualityData2)
}
})

For Standalone Shiny Applications:
In order to achieve what you desire easily i would recommend to generate an output for each plottype and only populate it when the corresponding input is selected.
Down below you can find a complete example of this.
Generally speaking it is not advised to mix outputTypes (different render functions on the server side) into one output function (on the UI side)
# allow sharing of dashboard
library(datasets)
library(flextable)
library(formattable)
library(dplyr)
library(shiny)
options(stringsAsFactors = FALSE)
qData <- data.frame(Name = "AAA", Releases = 10, Coverage = 23.0)
qData <- bind_rows(qData, data.frame(Name = "BBB", Releases = 35, Coverage = 88.0))
data_formatter_dd <-
formattable::formatter("span", style = x ~ style( font.weight = "bold",
color = ifelse(x > 80.0 & x <= 100.0, "green", ifelse(x > 50.0 & x <= 80.0, "orange", "red"))))
qualityData1 <- formattable::formattable(qData, align = c("l", rep("r", ncol(qData) - 1)),
list('Name' = formattable::formatter("span", style = ~ style(color = "grey", font.weight = "bold")),
'Coverage' = data_formatter_dd))
qualityData2 <- flextable(head(qData, col_keys = c("Name", "Releases", "Coverage")))
ui <- fluidPage(
fluidRow(
selectInput("qualityDataNum", label = h3("Quality Number Set"), choice = list("1" = 1, "2" = 2),
selected = 1)
,
tableOutput("table2"),
formattableOutput("table1")
)
)
server <- function(input, output, session) {
output$table1 <- renderFormattable({
req(as.integer(input$qualityDataNum) == 1)
qualityData1
})
output$table2 <- renderTable({
req(as.integer(input$qualityDataNum) != 1)
qualityData2$body$dataset
})
}
shiny::shinyApp(ui,server)
EDIT:
For RMarkdown Code
I just rechecked your question and noticed that you were specifically asking how to handle the problem in an RMarkdown document and not in a standalone shiny Application. So here is an Update answer:
For RMarkdown it is enough that you update the code in your Quality Statistics section to the following:
renderFormattable({
req(as.integer(input$qualityDataNum) == 1)
qualityData1
})
renderTable({
req(as.integer(input$qualityDataNum) != 1)
qualityData2$body$dataset
})
Here you render the table according to the select input, it would be possible to render also multiple tables using this approach at the same time. This works since the req() functions checks if the requirement is fullfilled and only proceeds with the procession (aka the rendering of the plot) when it does. If it doesn't just an empty object is returned. Since we are using an reactive input inside the render function the expression get evaluate every time the Input value changes. If you do not want that consider wrapping it with an isolate() function, which tells the encapsulation function to not revaluate the function every time the encapsulate reactive Values/Inputs changes.

Related

I am having trouble multiple keywords separated by comma which can be used as a successful input in the function - does anyone have ideas?

This is UMAP function and by entering the colors names you can color the clusters but it is not working. It says that it sees only one color and 20 are needed. This is Seurat package.
This is the function that I used originally without shiny and it works
DimPlot(data, reduction = "umap", cols = c(colors[30], colors[1], colors[2], colors[28], colors[3],
colors[4], colors[5], "mistyrose", "lightpink4", colors[21], "grey", colors[7], colors[9], colors[11], colors[24], colors[26], "magenta" ,"gold", "mistyrose2"), split.by = "orig.ident")
This code below if from the shiny app I am making
server <- function(input, output) {
col = renderText({ input$label.color })
cols <- reactive({input$cols})
output$value <- renderText({ input$cols})
output$tsneplot<-renderPlot({
input$ts
if (input$spl == "NULL") {
isolate(DimPlot(data, seed = input$seed.use,reduction = "tsne",pt.size=input$pt.size, label = T, repel = T, label.size = input$label.size, cells = NULL, cols = NULL, label.color = "red"))
} else {
isolate(DimPlot(data, reduction = "tsne",pt.size= input$pt.size, split.by = input$spl ,cells = NULL, cols = c(cols()), label = T, label.size = input$label.size, label.color = col(), repel = T ))
}
})
}
I have seen the output value of text cols it shows exactly in the upper portion of the code below but for some reason while it is in the app and running the dimplot function it thinks it is only one string. Without the concept of shiny it works the code is tested but in the shiny platform it is not.
enter image description here
To examine what value cols() actually returns in your app, you can include a console-like output in your test version:
ui <- fluidPage(
## ...
verbatimTextOutput('log')
## ...
)
server <- function(input, output, session) {
## ...
output$log <- renderPrint(cols())
## ...
}

Shiny datatable, filter columns by background color (as we have in excel)

How to filter out columns in shiny DT datatable based on cell color. Just like we have in excel.
[Need to filter the column with yellow color in background.]
Below is the code for cells with color:
input_data <- data.frame(Record_Status = c("Modified","NO","NO","Modified","NO","NO","Modified","NO","NO"),
Field_Changed = c("Brand,ratio","Gender","Name","ratio,Name,Gender","cost","Brand,cost","ratio,cost","cost","Name"),
Brand = c(3,6,9,12,15,18,21,24,27),
ratio = c (1,2,3,4,5,6,7,8,9),
cost = c(3,6,9,12,15,18,21,24,27),
Name = c("A","B","C","A","B","C","A","B","C"),
Gender = c("A","B","C","A","B","C","A","B","C"),
stringsAsFactors = FALSE)
# Build hidden logical columns for conditional formatting
dataCol_df <- ncol(input_data)
dataColRng <- 3:dataCol_df
argColRng <- (dataCol_df + 1):(dataCol_df * 2 -2)
df <- sapply(1:ncol(input_data),function(i) ifelse(input_data[[1]]=="Modified" &
str_detect(input_data[[2]], names(input_data)[i]),
"1","0"))
df <- df[,-c(1,2)]
input_data <- data.frame(input_data, df)
# Create Shiny Output
shinyApp(
ui =
navbarPage("Testing",dataTableOutput('dt')),
server = function(input, output, session) {
output$dt = DT::renderDataTable(
datatable(input_data,
# Hide logical columns
options=list(columnDefs = list(list(visible=FALSE,
targets=argColRng)))) %>%
# Format data columns based on the values of hidden logical columns
formatStyle(columns = dataColRng,
valueColumns = argColRng,
backgroundColor = styleEqual(c('1', '0'),
c("yellow", "white")))
)}
)
I think you have more than I issue here. For me the shiny app is not running and I believe this might be due to a mixup what should be in the ui and what in the server function.
About your original question. You could use the library DT and color the cells you like. This is independent of your shiny app, however, I believe you can use this also in the app, once you have the app running without the coloring.
library(DT)
datatable(input_data) %>% formatStyle(
'Brand', 'X1',
backgroundColor = styleEqual(c(0, 1), c('gray', 'yellow'))
)

The labels for my Sankey diagram (R, Plotly) do not show properly on the online version of my Shiny dashboard, but behave correctly locally

So I'm working on a Shiny dashboard, which I deployed on an AWS EC2 instance. It behaves exactly the same both locally and online save for one detail: the labels on the right hand side do not behave properly!
Here is the online version of the Plotly Sankey diagram in question:
Here is what I see locally when I run the app through RStudio.
There's absolutely no difference among any files. I don't see why the rendering of the labels should differ on both versions, but anyway, here's the relevant part of the code inside server.R:
# gender_sankey
nodes <- c('Hombres', 'Mujeres', unique(gender_df$UltimoGradoEstudios))
nodes <- nodes[c(1,2,4,3,5,7,12,10,8,6,11,9)]
gender_df$count <- 1
hom_stud <- aggregate(count ~ UltimoGradoEstudios, FUN = sum,
data = gender_df[gender_df$hom == 1,])
muj_stud <- aggregate(count ~ UltimoGradoEstudios, FUN = sum,
data = gender_df[gender_df$muj == 1,])
# Setting the sources and targets
hom_stud$src <- 0
muj_stud$src <- 1
hom_stud$tgt <- c(2,4,3,11,5,8,6,9,7)
muj_stud$tgt <- c(2,4,3,11,5,8,10,6,9,7)
# Setting the positions for the nodes
node_x <- c(0,0,1,1,1,1,1,1,1,1,1,1)
node_y <- c(0,1,-10:-1) # NOTE: Probably one of the fishy parts (2/2)
colors <- c('#C7FFA9','#E4A9FF','#2424FF','#2477FF','#248EFF','#249FFF',
'#24B3FF','#24C7FF','#24DEFF','#24F8FF','#24FFF8','#24FFEE')
# NOTE: Probably one of the fishy parts (1/2)
# Button to select/de-select all
observe({
if (input$selectall_sankey > 0) {
if (input$selectall_sankey %% 2 == 0){
updateCheckboxGroupInput(session = session,
inputId = "schoolSelect",
choices = list("Doctorado" = 'Doctorado',
"Maestría" = 'Maestría',
"Licenciatura" = 'Licenciatura',
"Pasante/Licenciatura trunca" = 'Pasante/Licenciatura trunca',
"Profesor Normalista" = 'Profesor Normalista',
"Técnico" = "Técnico",
"Preparatoria" = "Preparatoria",
"Secundaria" = 'Secundaria',
"Primaria" = "Primaria",
"No disponible" = 'No disponible'
),
selected = c(choices = list("Doctorado" = 'Doctorado',
"Maestría" = 'Maestría',
"Licenciatura" = 'Licenciatura',
"Pasante/Licenciatura trunca" = 'Pasante/Licenciatura trunca',
"Profesor Normalista" = 'Profesor Normalista',
"Técnico" = "Técnico",
"Preparatoria" = "Preparatoria",
"Secundaria" = 'Secundaria',
"Primaria" = "Primaria",
"No disponible" = 'No disponible'
))
)
} else {
updateCheckboxGroupInput(session = session,
inputId = "schoolSelect",
choices = list("Doctorado" = 'Doctorado',
"Maestría" = 'Maestría',
"Licenciatura" = 'Licenciatura',
"Pasante/Licenciatura trunca" = 'Pasante/Licenciatura trunca',
"Profesor Normalista" = 'Profesor Normalista',
"Técnico" = "Técnico",
"Preparatoria" = "Preparatoria",
"Secundaria" = 'Secundaria',
"Primaria" = "Primaria",
"No disponible" = 'No disponible'
),
selected = c())
}}
})
# Plot
output$gender_sankey <- renderPlotly({
hom_stud <- hom_stud[hom_stud$UltimoGradoEstudios %in% input$schoolSelect,]
muj_stud <- muj_stud[muj_stud$UltimoGradoEstudios %in% input$schoolSelect,]
node_x <- c(node_x[hom_stud$UltimoGradoEstudios %in% input$schoolSelect])
node_y <- c(node_y[hom_stud$UltimoGradoEstudios %in% input$schoolSelect])
colors <- c(colors[hom_stud$UltimoGradoEstudios %in% input$schoolSelect])
fig <- plot_ly(
type = "sankey",
orientation = "h",
arrangement = 'snap',
node = list(
label = nodes,
color = colors,
x = node_x,
y = node_y,
pad = 15,
thickness = 20,
line = list(
color = "black",
width = 0.5
)
),
link = list(
source = c(hom_stud$src, muj_stud$src),
target = c(hom_stud$tgt, muj_stud$tgt),
value = c(hom_stud$count, muj_stud$count)
)
)
fig <- fig %>% layout(
font = list(
size = 10
)
) %>% config(modeBarButtons = list(list('toImage'), list('resetScale2d')), displaylogo = F)
})
Packages used: shiny, shinydashboard, shinythemes and plotly (same versions both locally and on server). dplyr, magrittr, and ggplot2 are on the same version as well.
R version in my computer is 4.0.2, R version in the server is 3.6.3
It's not the cleanest implementation, specially on the button part, but it works perfectly locally! Note that I marked the sketchy practices I used, and where the problem could lie. Basically the default node order wasn't cutting it because the position on the right hand side itself contains information (Doctorado > Maestría > Licenciatura> ...), so I kind of forced a different order for the nodes through node_x and node_y. The thing is, the implementation works locally! What could be the reason for it not to work online?

How to edit a DT column and save the changes to trigger calculations in dependent columns?

I'm creating a shiny app that will be used by multiple people to see and edit data in a table format. I want the user to be able to edit one or more columns at a time. I've been using the DT package in R to do this, but I can't figure out how to save the edits made in the data table. This is crucial because there are dependant values in other columns that need to be recalculated.
If I set editable = TRUE I can change the value in one cell, but that is much too slow. When I set editable = "column" or "all" I can edit multiple cells quickly, but then the edits won't save, no matter how many times I hit return.
In the example below, all I'm trying to do is print the edited values to the console. If the values appear in the _cell_edit variable then I can use the editData function to save the changes.
I haven't found anything useful on StackOverflow yet, but I did find the following two blog posts helpful.
https://blog.rstudio.com/2018/03/29/dt-0-4/
https://rstudio.github.io/DT/shiny.html
# TEST APP DT
library(DT)
library(shiny)
library(tidyverse)
# Define UI for application that draws a histogram
ui <- fluidPage(
actionButton("save", "Click to Save Changes"),
DTOutput("dt_table")
)
# Define server logic required to draw a histogram
server <- function(input, output, session) {
data <-
data.frame(
A = c("Ones", "Twos", "Threes", "Total"),
B = c(1, 2, 3, 6),
C = c(1, 2, 3, 6),
stringsAsFactors = FALSE
) %>% mutate(D = B + C)
live = reactiveValues(df = NULL)
observe({
live$df <- data
})
output$dt_table <- renderDataTable({
datatable(
live$df,
rownames = FALSE,
editable = list(
target = "column",
disable = list(columns = c(1, 3))
)
)
})
proxy_dt_table <- dataTableProxy("dt_table")
observeEvent(input$save, {
info = input$dt_table_cell_edit
str(info)
row = info$row
col = info$col
val = info$value
print(paste0("Row: ", row))
print(paste0("Col: ", col))
print(paste0("Val: ", val))
})
}
# Run the application
shinyApp(ui = ui, server = server)
Right now, the values in the _cell_edit variable are empty.
NULL
[1] "Row: "
[1] "Col: "
[1] "Val: "
I would like to see something like this:
'data.frame': 200 obs. of 3 variables
[1] "Row: [1, 2, 3, 4, ...]"
[1] "Col: [1, 1, 1, 1, ...]"
[1] "Val: [5, 6, 7, 8, ...]"

ggplot won't use levels for x-axis order when a reactive input is empty

I am trying to create a shiny app with multiple sections, the section I am having trouble with right now displays calculated values on a ggplot graph. The user selects one Target gene from a dropdown list, and the graph displays calculated analysis values against a selection of other, Control genes. So far so simple.
I have a few default Control genesets, which I have preselected and that are always displayed, and then I have an option for the user to specify their own Control genes to perform analysis against. There is a checkbox that can be ticked if the user wants to select their own Controls. The user can also select different numbers of custom Controls, whereas the default controls each have sets of 3 Control genes.
Code for the default genesets as so:
ABC_control <- reactive(
Analysis_function(c("ACTB", "GAPDH", "TUBB")))
And code for the custom genesets is as so:
CUSTOM_control1 <- reactive( if (input$custom_checkbox1) {
Analysis_function(input$custom_controls1)
} else { NA } )
I have an if command in the Custom genesets so that they are not calculated and displayed if the tickbox is not checked.
First problem: The plot still displays an x axis label for the Custom control even if none is selected and the checkbox is not ticked. This is not a major problem, just an annoying one.
The second problem:
When displaying just the default genesets everything runs perfectly. And when the user selects their own Control genes, everything runs fine.
The problem is when the user ticks the CheckboxInput(), and the selectizeInput() for the custom control genes is still empty, the graph goes and re-orders its x-axis into alphabetical order, rather than the levels order that I have specified earlier. As soon as a Control gene is selected, it re-orders back into the levels order. The problem only occurs when the selectizeInput box is empty, or a new gene is being selected.
How can I force the plot to always display in the correct levels order, even when the reactive custom input is empty?
Also, preferably, how can I prevent the Custom input from being displayed on the graph at all unless the checkbox is ticked.
A full Shiny app data is below:
#### Load packages ####
library(shiny)
library(ggplot2)
library(dplyr)
#### Load data files ####
load("GeneNames.Rda")
load("Dataset.Rda")
#### Define UI ####
ui <- fluidPage(
#### Sidebar inputs ####
sidebarLayout(
sidebarPanel(width = 3,
#first wellpanel for selecting Target gene
h4("Target gene selection"),
wellPanel(
selectInput(
inputId = "gene_select",
label = NULL,
choices = GeneNames,
selected = "ESAM")),
#Second wellpanel for selecting custom Control genes
h4("Custom control genes"),
wellPanel(
checkboxInput(inputId = "custom_checkbox1",
label = "Custom 1:"),
conditionalPanel(condition = "input.custom_checkbox1 == true",
selectizeInput(inputId = "custom_controls1",
label = NULL,
choices = GeneNames,
multiple = TRUE,
options = list(openOnFocus = FALSE, closeAfterSelect = TRUE, maxOptions = 50, maxItems = 6))))
),
#### Mainpanel results Normal ####
mainPanel(width = 9,
#HTML code to have the last entry in any tables bolded (last entry is Mean in all tables)
#Results title and main bar plot graph
fluidRow(plotOutput(outputId = "celltype_bar_plot"),width = 9)
)))
#### Define server ####
server <- function(input, output) {
target_gene <- reactive({
input$gene_select
})
#### calculations ####
Analysis_function <- function(controls){
cor(Dataset[, target_gene()], Dataset[, controls])
}
ABC_control <- reactive(
Analysis_function(c("ACTB", "GAPDH", "TUBB")))
GHI_control <- reactive(
Analysis_function(c("ACTB", "GAPDH", "TUBB")))
DEF_control <- reactive(
Analysis_function(c("ACTB", "GAPDH", "TUBB")))
CUSTOM_control1 <- reactive( if (input$custom_checkbox1) {
Analysis_function(input$custom_controls1)
} else { NA } )
#### Analysis datatables Normal ####
control_list <- c("ABC_control", "GHI_control", "DEF_control", "CUSTOM_control1")
analysis_list <- reactive({ list(ABC_control(), GHI_control(), DEF_control(), CUSTOM_control1()) })
#generating melted data table of the induvidual analysed gene values, transposed to get in right format, and times = c(length()) to replicate titles the correct no of times
values_list <- reactive({
data.frame(Control_types2 = factor(rep(control_list, times = c(unlist(lapply(analysis_list(), length)))), levels =control_list),
values = c(unlist(lapply(analysis_list(), t))))
})
#Generating data table of the means of analysed values above
Mean_list <- reactive({
data.frame(Control_types = factor(control_list, levels =control_list),
Mean_correlation = c(unlist(lapply(analysis_list(), mean))))
})
#### Main Bar Plot Normal ####
output$celltype_bar_plot <- renderPlot({
ggplot() +
geom_point(data = values_list(),aes(x=Control_types2, y=values,size = 7, color = Control_types2), show.legend = FALSE, position=position_jitter(h=0, w=0.1), alpha = 0.7) +
geom_boxplot(data = Mean_list(), aes(Control_types, Mean_correlation), size = 0.5, colour = "black")
})
}
#### Run application ####
shinyApp(ui = ui, server = server)
I can't fully test this solution since the data you provided isn't available (so I can't run the app), but I suspect that the following should help.
First, by using ordered or factor(..., ordered = TRUE) you can tell the graph what order to put label in.
Second, in order to prevent the column from showing up on the graph you must remove all datapoints for that column INCLUDING NA.
control_list <- c("ABC_control", "GHI_control", "DEF_control", "CUSTOM_control1")
# Some data to try out
values_list <- data.frame(
Control_types2 = ordered(rep(control_list, times = 4), levels =control_list),
values = c(0.25,0.50,0.75,NA)
)
Mean_list <- data.frame(
Control_types = ordered(control_list, levels =control_list),
Mean_correlation = c(0.25,0.50,0.75,NA)
)
# Original plot code
ggplot() +
geom_point(data = values_list,aes(x=Control_types2, y=values,size = 7, color = Control_types2), show.legend = FALSE, position=position_jitter(h=0, w=0.1), alpha = 0.7) +
geom_boxplot(data = Mean_list, aes(Control_types, Mean_correlation), size = 0.5, colour = "black")
# New plot with NA values removed
ggplot() +
geom_point(data = values_list %>% filter(!is.na(values)),
aes(x=Control_types2, y=values,size = 7, color = Control_types2),
show.legend = FALSE,
position=position_jitter(h=0, w=0.1),
alpha = 0.7) +
geom_boxplot(data = Mean_list %>% filter(!is.na(Mean_correlation)),
aes(Control_types, Mean_correlation),
size = 0.5,
colour = "black")

Resources