Related
EDIT WITH MWE BELOW
I have below a snippet of my code which is part of a larger app. I'm trying to rewrite the app to work with R6 classes and gargoyle as per this article. However, I cannot figure out why the observe part of the data below does not trigger except when it's initialized. To my understanding should if observe all the filters that are in input based on the map function, am I wrong?
output$filters <- renderUI({
gargoyle::watch("first thing")
data <- Data$get_data(unfiltered = TRUE)
data_names <- names(data)
if(nrow(data) > 0){
map(data_names, ~ render_ui_filter(data[[.x]], .x))
}
}
)
observe({
data <- Data$get_data(unfiltered = TRUE)
data_names <- names(data)
if(ncol(data) > 0){
each_var <- map(data_names, ~ filter_var(data[[.x]], input[[paste0("filter",.x)]]))
Transactions <- Data$set_filters(reduce(each_var, `&`))
gargoyle::trigger("second thing")
}
})
I've had a working case of the second reactive element like this:
selectedData <- reactive({
if(nrow(data()) > 0){
each_var <- map(dataFilterNames(), ~ filter_var(data()[[.x]], input[[paste0("filter",.x)]]))
reduce(each_var, `&`)
}
})
where data and dataFilterNames are reactiveVal and dataFilterNames is the column names of data.
Here you can find render_ui_filter and filter_var:
render_ui_filter <- function(x, var) {
if(all(is.null(x) | is.na(x))){
#If all data is null, don't create a filter from it
return(NULL)
}
id <- paste0("filter",var)
var <- stringr::str_to_title(var)
if (is.numeric(x)) {
if(is.integer(x)){
step = 1
}
else{
step = NULL
}
rng <- range(x, na.rm = TRUE)
sliderInput(id,
var,
min = rng[1],
max = rng[2],
value = rng,
round = TRUE,
width = "90%",
sep = " ",
step = step
)
} else if (is.factor(x)) {
levs <- levels(x)
if(length(levs) < 5){
pickerInput(id, var, choices = levs, selected = levs, multiple = TRUE,
options = list(
title = sprintf("Filter on %s...", var),
#`live-search` = TRUE,
#`actions-box` = TRUE,
size = 10
))
}else {
pickerInput(id, var, choices = levs, selected = levs, multiple = TRUE,
options = list(
title = sprintf("Filter on %s...", var),
`live-search` = TRUE,
`actions-box` = TRUE,
size = 10,
`selected-text-format` = "count > 5"
))
}
} else if (is.Date(x)){
dateRangeInput(id,
var,
start = min(x),
end = max(x),
weekstart = 1,
autoclose = FALSE,
separator = "-")
} else if (is.logical(x)) {
pickerInput(id, var, choices = unique(x), selected = unique(x), multiple = TRUE,
options = list(
title = sprintf("Filter on %s...", var),
`live-search` = TRUE,
#`actions-box` = TRUE,
size = 10
))
} else {
# Not supported
NULL
}
}
filter_var <- function(x, val) {
if(all(is.null(x) | is.na(x))){
#If all data is null, don't create a filter from it
return(TRUE)
}
if (is.numeric(x)) {
!is.na(x) & x >= val[1] & x <= val[2]
} else if (is.factor(x)) {
x %in% val
} else if(is.Date(x)){
!is.na(x) & x >= val[1] & x <= val[2]
} else if (is.logical(x)) {
x %in% val
} else {
# No control, so don't filter
TRUE
}
}
Edit: Here is a MWE that can be run in a notebook for example. It does not currently work since the gargoyle trigger triggers the observe it is in and we end up in a infinity loop. If you remove that you can see that the normal reactive part works, but the R6 version does not create the table ever.
if (interactive()){
require("shiny")
require("R6")
require("gargoyle")
require("purrr")
require("stringr")
# R6 DataSet ----
DataSet <- R6Class(
"DataSet",
private = list(
.data = NA,
.data_loaded = FALSE,
.filters = logical(0)
),
public = list(
initialize = function() {
private$.data = data.frame()
},
get_data = function(unfiltered = FALSE) {
if (!unfiltered) {
return(private$.data[private$.filters, ])
}
else{
return(private$.data)
}
},
set_data = function(data) {
stopifnot(is.data.frame(data))
private$.data <- data
private$.data_loaded <- TRUE
private$.filters <- rep(T, nrow(private$.data))
return(invisible(self))
},
set_filters = function(filters) {
stopifnot(is.logical(filters))
private$.filters <- filters
}
)
)
# Filtering ----
render_ui_filter <- function(x, var) {
if(all(is.null(x) | is.na(x))){
#If all data is null, don't create a filter from it
return(NULL)
}
id <- paste0("filter",var)
var <- stringr::str_to_title(var)
if (is.numeric(x)) {
if(is.integer(x)){
step = 1
}
else{
step = NULL
}
rng <- range(x, na.rm = TRUE)
sliderInput(id,
var,
min = rng[1],
max = rng[2],
value = rng,
round = TRUE,
width = "90%",
sep = " ",
step = step
)
} else {
# Not supported
NULL
}
}
filter_var <- function(x, val) {
if(all(is.null(x) | is.na(x))){
#If all data is null, don't create a filter from it
return(TRUE)
}
if (is.numeric(x)) {
!is.na(x) & x >= val[1] & x <= val[2]
} else {
# No control, so don't filter
TRUE
}
}
# Options ----
options("gargoyle.talkative" = TRUE)
options(shiny.trace = TRUE)
options(shiny.fullstacktrace = TRUE)
ui <- function(request){
tagList(
h4('Filters'),
uiOutput("transactionFilters"),
h4('Reactive'),
tableOutput("table_reactive"),
h4('R6'),
tableOutput("table_r6")
)
}
server <- function(input, output, session){
gargoyle::init("df_r6_filtered")
Name <- c("Jon", "Bill", "Maria", "Ben", "Tina")
Age <- c(23, 41, 32, 58, 26)
df <- reactive(data.frame(Name, Age))
df_r6 <- DataSet$new()
df_r6$set_data(data.frame(Name, Age))
output$transactionFilters <- renderUI(
map(names(df()), ~ render_ui_filter(x = df()[[.x]], var = .x))
)
selected <- reactive({
if(nrow(df()) > 0){
each_var <- map(names(df()), ~ filter_var(df()[[.x]], input[[paste0("filter",.x)]]))
reduce(each_var, `&`)
}
})
observe({
data <- df_r6$get_data(unfiltered = TRUE)
data_names <- names(data)
if(ncol(data) > 0){
each_var <- map(data_names, ~ filter_var(data[[.x]], input[[paste0("filter",.x)]]))
filters_concatted <- reduce(each_var, `&`)
df_r6$set_filters(filters_concatted)
gargoyle::trigger("df_r6_filtered")
}
})
output$table_reactive <- renderTable(df()[selected(),])
gargoyle::on("df_r6_filtered",{
output$table_r6 <- renderTable(df_r6$get_data())
})
}
shinyApp(ui, server)
}
EDIT2: I noticed that the gargoyle::trigger("df_r6_filtered") creates a infinity loop of triggering the observe component. I'm not sure how to get out of it and that's what I am looking for help with.
The answer was simpler then expected of course. Just change the observe to a observeEvent on all of the input elements regarding the filter, i.e. like this:
observeEvent(
eventExpr = {
data <- df_r6$get_data(unfiltered = TRUE)
data_names <- names(data)
map(data_names, ~ input[[paste0("filter",.x)]])
},
{
...
}
})
I need to be able to access each variable's data in my data frame, after the user has selected and uploaded a local csv file. This code is the part of my Shiny script where I create and modify the csv file read in by the user. "rv" is the data, which is a reactiveValues dataframe, so it can be modified.
Variable names are chosen by the user through a radio button group (shown here, but defined in the ui part of the script). The other code is in the server portion of the script.
radioButtons('radiovarGroup1',label = h5("Choose a Variable to Analyze:"),
choices = list('TA' = 'TA','PP' = 'PP', 'US' = 'us', 'UD' = 'ud', 'UE' = 'ue',
'UG' = 'ug', 'UH' = 'uh', 'XR' = 'xr', 'RW' = 'rw', 'PA' = 'pa', 'TB4' = 'tb4',
'TV2' = 'tv2', 'TV4' = 'tv4', 'TV8' = 'tv8', 'TV20' = 'tv20', 'TV40' = 'tv40',
'MV2' = 'mv2', 'MV4' = 'mv4', 'MV8' = 'mv8', 'MV20' = 'mv20', 'MV40' = 'mv40',
'VB' = 'vb', 'TA40' = 'ta40', 'TA120' = 'ta120', 'SD' = 'sd'),inline = TRUE, selected = NULL),
var_names = c('TA','PP','US','UD','UE','UG','UH','XR','RW','PA','TB4','TV2','TV4',
'TV8','TV20','TV40','MV2','MV4','MV8','MV20','MV40','VB','TA40','TA120','SD')
rv <- reactiveValues(df = NULL)
#This function is responsible for loading in the selected file
observe({
req(input$file_selector)
rv$df <- read.csv(paste0(parseDirPath(c(home = 'C:\\Users\\Ruben\\Desktop\\Test_QC_Program\\FiveMin'), file_dir()),'\\',input$file_selector),skip=1) # Simplified for testing
})
# This previews the CSV data file
output$filetable <- renderDataTable({
rv$df
})
observeEvent(input$qc_final_cols, {
if (input$qc_final_cols){
for (v in 1:length(var_names)){
ind <- which(colnames(rv$df) == var_names[v])
rv$df <- rv$df %>%
add_column(z = NA,.after = ind)
colnames(rv$df)[ind+1] <- paste0(var_names[v],'_QC')
rv$df <- rv$df %>%
add_column(y = NA,.after = ind+1)
colnames(rv$df)[ind+2] <- paste0(var_names[v],'_Final')
}
}
})
output$checked_var <- renderPrint({
input$radiovarGroup1})
variable_data <- reactive({get(rv$df[,which(colnames(rv$df) == input$radiovarGroup1)])})
Why do I keep getting an "object of type closure is not subsettable' error returned for variable_data? I can render the rv$df data table just fine, but I can't extract data from it for some reason.
I made a shiny dashboard that connects to a postegreDB and get a value from a table, then subset it, and then transform it to a wide format using reshape2. I want to update the value directly from the dashboard, and then push them into the database.
I used this link for inspiration: https://github.com/MangoTheCat/dtdbshiny
This is the code I made:
server <- function(input, output, session) {
# Generate reactive values
rvs <- reactiveValues(
data = NA,
dataWide = NA,
dataSub = NA,
cdfilTmp = NA,
cdfilTmp2 = NA,
dataWideTmp = NA,
dbdata = NA,
dataSame = TRUE,
req = NA,
tabId = NA,
listeSeuil = NA,
dataMod = NA
)
# Generate source via reactive expression
mysource <- reactive({
dbGetQuery(pool, "SELECT * from bilanmasse.v_export_r_scen_seuil")
})
# Observe the source, update reactive values accordingly
observeEvent(mysource(), {
# Lightly format data by arranging id
# Not sure why disordered after sending UPDATE query in db
data <- mysource() %>% arrange(idscenar)
data <- dbGetQuery(pool, "SELECT * from bilanmasse.v_export_r_scen_seuil")
rvs$cdfilTmp <- paste(data$ordreseuil, data$nomfiliere, sep="-")
data$cdfiliere <- rvs$cdfilTmp
data <- data[c("idscenar", "nomscenar", "codeparam", "cdusage", "cdlithoprof", "cdfiliere", "valseuil")]
rvs$data <- data
rvs$dbdata <- data
rvs$listeSeuil <- unique(rvs$data[,1])
rvs$tabId <- dbGetQuery(pool, "SELECT * from bilanmasse.scenar_testr")
updateSelectInput(session, "listScen",
label = "Choix du scenario",
choices = isolate(rvs$listeSeuil)
)
})
rvs$dataSub <- reactive({ subset(rvs$data, rvs$data[,1] == input$listScen) })
rvs$dataWide <- reactive({ dcast(rvs$dataSub(), idscenar+nomscenar+codeparam+cdusage+cdlithoprof~cdfiliere, value.var="valseuil") })
rvs$dataWideTmp <- reactive({ rvs$dataWide() })
ScenBase <- reactive({ subset(rvs$data, rvs$data[,1] == 2) })
listeParam <- reactive({ unique(ScenBase()[,3]) })
listeUsage <- reactive({ unique(ScenBase()[,4]) })
listeLithoProf <- reactive({ unique(ScenBase()[,5]) })
listeTraitement <- reactive({ unique(ScenBase()[,6]) })
#
# render the table
output$tabScSeuil <- renderDataTable(
rvs$dataWide(), rownames = FALSE, editable = TRUE, selection = 'none', filter= "top", options = list(
columnDefs = list(list(className = 'dt-center', targets = "_all")))
)
proxy3 = dataTableProxy('tabScSeuil')
observeEvent(input$tabScSeuil_cell_edit, {
info = input$tabScSeuil_cell_edit
i = info$row
j = info$col = info$col + 1 # column index offset by 1
v = as.numeric(info$value)
rvs$dataWideTmp[i,j] <- v
output$test <- renderPrint(rvs$dataWideTmp[i,j])
})
}
Everything work perfectly expect when I want to update the new value into the table: I got this error:
Error in [: object of type 'closure' is not subsettable
So I tried to use an SQL request instead of a subset:
observeEvent(input$listScen, {
val <- as.character(input$listScen)
req <- paste0("SELECT * from bilanmasse.v_export_r_scen_seuil WHERE idscenar = ", val)
observeEvent(input$listScen, { dataSub <- dbGetQuery(pool, req) })
#cdfilTmp2 <- paste(dataSub[,6], dataSub[,7], sep="-")
#dataSub[,9] <- cdfilTmp2
#dataSub <- dataSub[c("idscenar", "nomscenar", "codeparam", "cdusage", "cdlithoprof", "V9", "valseuil")]
#colnames(dataSub) <- c("idscenar", "nomscenar", "codeparam", "cdusage", "cdlithoprof", "cdfiliere", "valseuil")
#dataWide <- dcast(dataSub, idscenar+nomscenar+codeparam+cdusage+cdlithoprof~cdfiliere, value.var="valseuil")
#dataWideTmp <-dataWide
output$test <- renderPrint(req)
})
But I got a weird error, when I print req, the request is OK:
[1] "SELECT * from bilanmasse.v_export_r_scen_seuil WHERE idscenar =
2"
But in the R console, I got an error:
Warning in postgresqlQuickSQL(conn, statement, ...) : Could not
create execute: SELECT * from bilanmasse.v_export_r_scen_seuil WHERE
idscenar =
Does someone know a solution to make this?
I am writing a shiny app (shinydashboard) that looks like the figure (the app run on my company private network,so I can't share the link to it).
The dataset consists of a table containing the expression values of different genes (rows) for different samples (columns).
The app should return a subset of that table based on the search criteria selected by the user. Information about the samples are stored in a different table (B38.Metadata in the code), that looks like this:
SampleID,RNA.ID,RNAseq.ID,Name,Description,Tissue Type,...
CP3027,CP3027,74,Hs514,Aortic_Endothelial,Vascular system,Endothelial,...
CP3028,CP3028,76,HEr1,Aortic_Endothelial,Vascular system,Endothelial,...
At every search, the metadata are checked and the main table is subset accordingly.
My approach has been to write a function for each search types (SearchByGene,SearchByTissue,...), and
use if-else statements to account for all the possible combinations.
For example, filter by GeneName, Tissue type, and Name, but not for the other options.
This led to a massive 14 if-else block, spanning almost 50 lines of code (see below).
everything works, but the code is dreadful to read and debug.
Furthermore the idea of adding additional search possibilities (e.g. search by sequencing technique)
made me shiver.
I considered using a switch construct, but, having multiple conditions to test I'm not sure it will clean the code too much.
Is there a way of simplify the if-else block with something easier to read and, especially, maintain?
Searchfunction <- function(dataSet2){
selectedTable <- reactive({
# Create a DF with only the gene names
DFgeneLevel <- DummyDFgeneLevel(dataSet2) # not used for now
# Subset by Columns first
if(is.null(input$tissues) && is.null(input$samples) && is.null(input$Name)){
TableByColumns <- dataSet2
} else if(!is.null(input$tissues) && !is.null(input$samples) && !is.null(input$Name)){
TableByTissue <- SearchByTissue(input$tissues,B38.metadata,dataSet2)
TableBySample <- SearchBySample(input$samples,TableByTissue)
TableByColumns <- SearchByName(input$Name,B38.metadata,TableBySample)
} else if(!is.null(input$tissues)){
if(is.null(input$samples) && is.null(input$Name)){
TableByColumns <- SearchByTissue(input$tissues,B38.metadata,dataSet2)
} else if(is.null(input$samples) && !is.null(input$Name)){
TableByTissue <- SearchByTissue(input$tissues,B38.metadata,dataSet2)
TableByColumns <- SearchByName(input$Name,B38.metadata,TableByTissue)
} else if(!is.null(input$samples) && is.null(input$Name)){
TableByTissue <- SearchByTissue(input$tissues,B38.metadata,dataSet2)
TableByColumns <- SearchBySample(input$samples,TableByTissue)
}
} else if(is.null(input$tissues)){
if(is.null(input$samples) && !is.null(input$Name)){
TableByColumns <- SearchByName(input$Name,B38.metadata,dataSet2)
} else if(!is.null(input$samples) && is.null(input$Name)){
TableByColumns <- SearchBySample(input$samples,dataSet2)
} else if(!is.null(input$samples) && !is.null(input$Name)){
TableByName <- SearchBySample(input$samples,dataSet2)
TableByColumns <- SearchByName(input$Name,B38.metadata,TableByName)
}
}
# Collect all the inputs & subset by Rows
#genes.Selected <- toupper(genes.Selected) # can't use it as some genes contains lowerletters
genesFromList <- unlist(strsplit(input$genesLists,","))
genes.Selected <- unlist(strsplit(input$SearchCrit," "))
if(input$SearchCrit == '' && input$genesLists == 0){
TableByRow <- TableByColumns
} else if(input$SearchCrit != '' && input$genesLists != 0){
TableByList <- subset(TableByColumns, TableByColumns$GeneName %in% genesFromList)
TableByRow <- subset(TableByList, TableByList$GeneName %in% genes.Selected)
} else if(input$SearchCrit != '' && input$genesLists == 0){
TableByRow <- subset(TableByColumns, TableByColumns$GeneName %in% genes.Selected)
} else if(input$SearchCrit == '' && input$genesLists != 0) {
TableByRow <- subset(TableByColumns, TableByColumns$GeneName %in% genesFromList)
}
return(TableByRow)
})
}
Is that what you are trying to achieve ?
Filter samples that match your attributes based on your metadata and display gene expressions only for these samples ?
library(shiny)
library(dplyr)
ui <- fluidPage(
titlePanel("mtcars"),
sidebarLayout(
sidebarPanel(
selectInput("vs",
label = "vs",
choices = c(0, 1),
selected = NULL,
multiple = TRUE),
selectInput("carb",
label = "carb",
choices = c(1, 2, 3, 4, 6, 8),
selected = NULL,
multiple = TRUE),
selectInput("gear",
label = "gear",
choices = c(3, 4, 5),
selected = NULL,
multiple = TRUE)
),
mainPanel(
tabsetPanel(
tabPanel("Expression values", tableOutput("mainTable")),
tabPanel("ID filtering", tableOutput("table"))
)
)
)
)
server <- function(input, output) {
samples.df <- data.frame(ID = paste0("ID", as.character(round(runif(nrow(mtcars),
min = 0,
max = 100 * nrow(mtcars))))),
gear = as.factor(mtcars$gear),
carb = as.factor(mtcars$carb),
vs = as.factor(mtcars$vs))
values.df <- cbind(paste0("Feature", 1:20),
as.data.frame(matrix(runif(20 * nrow(samples.df)), nrow = 20)))
colnames(values.df) <- c("Feature", as.character(samples.df$ID))
vs.values <- reactive({
if (is.null(input$vs)) {
return(c(0, 1))
} else {
return(input$vs)
}
})
carb.values <- reactive({
if (is.null(input$carb)) {
return(c(1, 2, 3, 4, 6, 8))
} else {
return(input$carb)
}
})
gear.values <- reactive({
if (is.null(input$gear)) {
return(c(3, 4, 5))
} else {
return(input$gear)
}
})
filtered.samples.df <- reactive({
return(samples.df %>% filter(gear %in% gear.values(),
vs %in% vs.values(),
carb %in% carb.values()))
})
filtered.values.df <- reactive({
selected.samples <- c("Feature", names(values.df)[names(values.df) %in% filtered.samples.df()$ID])
return(values.df %>% select(selected.samples))
})
output$mainTable <- renderTable({
filtered.values.df()
})
output$table <- renderTable({
filtered.samples.df()
})
}
shinyApp(ui = ui, server = server)
You can try something like this, where we loop over the inputs and subset on the according column if the input is not null.
Hope this helps!
library(shiny)
ui <- fluidPage(
selectizeInput('mpg','mpg:',unique(mtcars$mpg),multiple=T),
selectizeInput('cyl','cyl:',unique(mtcars$cyl),multiple=T),
selectizeInput('gear','gear:',unique(mtcars$gear),multiple=T),
selectizeInput('carb','carb:',unique(mtcars$carb),multiple=T),
tableOutput('mytable')
)
server <- function(input,output)
{
output$mytable <- renderTable({
df = mtcars
select_inputs = c('mpg','cyl','gear','carb')
for (inp in select_inputs)
{
if(!is.null(input[[inp]]))
{
df = df[df[[inp]] %in% input[[inp]],]
}
}
df
})
}
shinyApp(ui,server)
When I'm trying to run this code as a Shiny app in R, I'm facing this error:
Error in renderDataTable({ : unused argument (rownames = FALSE)
output$table <- renderDataTable({
if(is.null(fdata()))
{return ()}
if(input$flevel=="Weekly")
{
if(input$flevel2=="Store")
{
data<-fdata()
data <- data[data$SKU == input$xcol,]
data <- data[data$Store == input$ycol,]
data
}
else if(input$flevel2=="Region")
{
data<-fdata()
data <- data[data$SKU == input$xcol,]
data <- data[data$Region == input$ycol,]
# data <- aggregate(Sales~Date+SKU+Region_Name,data = data,FUN = sum,na.rm=TRUE)
data
}
}
else if(input$flevel=="Monthly")
{
if(input$flevel2=="Store")
{
dmsales<-MonthManp()
data<-dmsales[[4]]
data <- data[data$SKU == input$xcol,]
data <- data[data$Store == input$ycol,]
data
}
else if(input$flevel2=="Region")
{
dmsales<-MonthManp()
data<-dmsales[[4]]
data <- data[data$SKU == input$xcol,]
data <- data[data$Region == input$ycol,]
data
# data <- aggregate(Sales~Date+product_id+loc_id+Channel_Name,data = data,FUN = sum,na.rm=TRUE)
}
} }, options = list(searching = FALSE),rownames=FALSE)
All my brackets are properly closed and the rownames is inside the datatable not the options tab. Can anyone pls help me in this. I'm a newbie in Shiny.
The params for
renderDataTable are:
renderDataTable(expr, options = NULL, searchDelay = 500,
callback = "function(oTable) {}", escape = TRUE, env = parent.frame(),
quoted = FALSE, outputArgs = list())
You could use the following format:
output$table <- DT::renderDataTable({
DT::datatable(df,options = list(searching=FALSE),rownames= FALSE)
})
Hope this helps!