I´m having problems combining two features while building a data table:
I use “bSearchable” to select 1 column that I want to use the search tool to filter
I use "checkboxInput" to select the columns the user wants to see.
Both work separately, but not together. If I uncheck a column in my menu input, the data disappears - like applying a filter and no data was found. How can I fix this?
library(shiny)
runApp(list(ui=(fluidPage(
pageWithSidebar(
headerPanel('Title'),
sidebarPanel(
helpText('Text about the table'),
checkboxInput('columns','I want to select the columns' , value = FALSE),
conditionalPanel(
condition= "input.columns == true",
checkboxGroupInput('show_vars', 'Select the columns that you want to see:', names(iris[1:4]),
selected = names(iris[1:4]))
),
downloadButton('downloadData', 'Download'),width = 3
),
mainPanel(
tags$head(tags$style("tfoot {display: table-header-group;}")),
dataTableOutput("mytable1"),width = 9
)
))
)
,
server=(function(input, output) {
library(ggplot2)
library(XLConnect)
#DATA
tabel<- reactive({
iris[,c(input$show_vars,"Species"), drop = FALSE]
})
# OUTPUT
output$mytable1 = renderDataTable({
tabel()},
options = list(
aoColumns = list(list(bSearchable = FALSE), list(bSearchable = FALSE),list(bSearchable = FALSE),
list(bSearchable = FALSE),list(bSearchable = TRUE)),
bFilter=1, bSortClasses = 1,aLengthMenu = list(c(10,25,50, -1), list('10','25', '50', 'Todas')),iDisplayLength = 10
)
)
output$downloadData <- downloadHandler(
filename = function() { paste('tabela_PSU','.xlsx', sep='') },
content = function(file){
fname <- paste(file,"xlsx",sep=".")
wb <- loadWorkbook(fname, create = TRUE)
createSheet(wb, name = "Sheet1")
writeWorksheet(wb, tabel(), sheet = "Sheet1")
saveWorkbook(wb)
file.rename(fname,file)
},
)
})
))
The problem is by filtering the data iris based on input$show_vars, you are changing the number of columns of the DataTable.
However, you have defined a fixed aoColumns option, which implies your DataTable has five columns (four non-searchable, one searchable).
Therefore, when you deselect any checkbox inputs, the filtered data doesn't match the specified options. As a result, nothing is displayed.
That is, although your data in the DataTable is reactive, the options, however, are NOT reactive.
If you read the renderDataTable's document carefully, you will see that you can pass two types of variables to the options argument:
options A list of initialization options to be passed to DataTables, or a function to return such a list.
The differences are:
If you specify options as a list, Shiny assumes that the options are fixed; But since you are dynamically filtering the data based on input$show_vars, you should dynamically change the options for aoColumns as well.
If you pass a function as an argument for options, Shiny will know that the options are also reactive. Hence Shiny will also update the options when the data (in your case, the data.frame encapsulated in the reactive variable named tabel) updates.
You may already know that reactive variables are themselves functions. They are evaluated in a reactive environment and when evaluated, they return the current state/value of the data. This is why you pass tabel() instead of tabel to renderDataTable.
The solution then, is to wrap the entire options list into a reactive variable (hence a function as well). Specifically, we want to dynmaically set the aoColumns option so that the number of bSearchable toggles matches the number of columns shown in the DataTable.
Below I only show the updated server part, since there's nothing needs to be changed in the UI part.
server.R
shinyServer(function(input, output) {
library(ggplot2)
library(XLConnect)
#DATA
tabel<- reactive({
iris[,c(input$show_vars,"Species"), drop = FALSE]
})
# wrap the `options` into a reactive variable (hence a function) so that it will
# be evaluated dynamically when the data changes as well.
# `dt_options` is reactive in the sense that it will reflect the number of rows
# visible based on the checkboxInput selections.
dt_options <- reactive({
# dynamically create options for `aoColumns` depending on how many columns are selected.
toggles <- lapply(1:length(input$show_vars), function(x) list(bSearchable = F))
# for `species` columns
toggles[[length(toggles) + 1]] <- list(bSearchable = T)
list(
aoColumns = toggles,
bFilter = 1, bSortClasses = 1,
aLengthMenu = list(c(10,25,50, -1), list('10','25', '50', 'Todas')),
iDisplayLength = 10
)
})
# OUTPUT
output$mytable1 = renderDataTable({
tabel()},
options = dt_options
)
output$downloadData <- downloadHandler(
filename = function() { paste('tabela_PSU','.xlsx', sep='') },
content = function(file){
fname <- paste(file,"xlsx",sep=".")
wb <- loadWorkbook(fname, create = TRUE)
createSheet(wb, name = "Sheet1")
writeWorksheet(wb, tabel(), sheet = "Sheet1")
saveWorkbook(wb)
file.rename(fname,file)
},
)
})
(Note that I separate the UI part and server part into ui.R and server.R.)
Related
I would like to be able to upload a dataset, select a set of columns, transform the selected columns (i.e. apply a function), then download the modified file. I have been trying to do so with the following code:
library(shiny)
library(DT)
library(shinyWidgets)
library(plyr)
library(dplyr)
library(RecordLinkage)
library(readxl)
cleanup <- function(x){
x <- as.character(x) # convert to character
x <- tolower(x) # make all lowercase
x <- trimws(x, "both") # trim white space
return(x)
}
ui <- fluidPage(
h2("Record Linkage Data"),
fileInput("file1", "Upload file for cleaning", accept = c("xls", "csv"), multiple = F),
actionButton(inputId = "clean", label = "Clean Data"),
downloadButton("download1", "Download file1"),
pickerInput(width = "75%",
inputId = "pick_col1",
label = "Select columns to display",
choices = colnames(file1),
selected = colnames(file1),
options = list(
`actions-box` = T,
`selected-text-format` = paste("count > ", length(colnames(file1)) - 1),
`count-selected-text` = "Alle",
liveSearch = T,
liveSearchPlaceholder = T
),
multiple = T),
DT::dataTableOutput("mytable")
)
load_path <- function(path) {
req(input$file)
ext <- tools::file_ext(path)
if (ext == "csv"){
read.csv(path, header = T)
} else if (ext == "xls" || ext == "xlsx"){
read_excel(path)
} else{
stop("Unknown extension: '.", ext, "'")
}
}
server <- function(input, output, session){
file1 <- reactive(load_path(input$selection$datapath[[1]]))
#file2 <- reactive(load_path(input$selection$datapath[[2]]))
eventReactive(input$clean, {
output$mytable <- DT::renderDataTable({
data.frame(lapply(select(file1, input$pick_col1), cleanup))
})
})
output$download <- downloadhandler(
filename = function(){
paste0(tools::file_path_sans_ext(input$filename), ".csv")
},
content = function(file){
write.csv(data(), file)
}
)
}
shinyApp(ui, server)
When I run the above code, I get the error : Error in is.data.frame(x) : object 'file1' not found. I am unsure why this is but I have been struggling to understand naming things in shiny. For example: I want to upload file1, then transform it. Do I continue to refer to file1 when I want to download it? These may seem like silly questions but I am asking because I don't know and I'm trying to learn. There seem to be lots of different approaches.
I would like to:
1. Load a file
2. Select columns (pickerInput is what I have been trying, but selectInput would suffice I suppose)
3. via action button, apply a pre-specified function to the selected columns
4. download the transformed dataset as a .csv
I've encountered some problems
It is a very silly one (it happens to all of us). You should write downloadHandler instead of downloadhandler.
The main problem: Your pickerInput is trying to select the column names of the data frame file1 when it does not exists. When you run the application the code is trying to find a file1 data frame and look its column names, but since at that time you haven't uploaded anything yet, it throws an error.
On how you read files: I am not familiar with how you read files, I suggest you do something similar than what is done in this example. https://shiny.rstudio.com/gallery/file-upload.html. Note you need to use a read.* function and point the result to another name, df in the example.
How would I solve it:
1. Set choices and selected options to NULL by default. Something like the following should work:
pickerInput(width = "75%",
inputId = "pick_col1",
label = "Select columns to display",
choices = NULL,
selected = NULL,
options = list(
`actions-box` = T,
# `selected-text-format` = paste("count > ", length(colnames(file1)) - 1),
`count-selected-text` = "Alle",
liveSearch = T,
liveSearchPlaceholder = T
),
multiple = T)
Add an updatePickerInput in the server side within an observeEvent. Something like this should work.
observeEvent(input$file1, {
req(input$file1) # ensure the value is available before proceeding
df <- read.csv(input$file1$datapath)
updatePickerInput(session = session,
inputId = "pick_col1",
choices = colnames(df),
# ... other options)
})
I haven't looked much if there are other problems with the code.
I suggest you start from the example in the link shared and start modifying it until you get what you want.
If that does not work, let me know and I can try to figure it out
Good luck!
To filter a data.frame with lots of variables I created a selectizeInput which allows you to select one of the columns of the data. This then creates another selectizeInput for the selected variable which can be used for subsetting the data. The selected value of the second selectizeInput is rendered below.
This is what it looks like
I want to render the selected values of these inputs so that these can be deleted by the user by clicking the black cross. Also a selection of var2 should not be deleted when the Filter selectizeInput is changed to var1.
So it should look like this (assuming the user previously selected value z in var2 and then value a in var1.
Anyone knows a good solution in shiny?
This is the code:
library(shiny)
data <- data.frame(var1 = c("a", "b"), var2 = c("y", "z"))
ui <- fluidPage(
selectizeInput("filter", label = "Filter",
multiple = FALSE, choices = c("var1", "var2")),
uiOutput("filter_var"),
uiOutput("selected_filter_value")
)
server <- function(input, output) {
observeEvent(input$filter, {
# dynamically generate selectizeInput for filter
output$filter_var <- renderUI({
selectizeInput(input$filter, label = input$filter,
choices = data[input$filter], multiple = TRUE)
})
})
# show selected filter values
# selected filter values should stay when choosing new input filter variable
# these should be deletable
observeEvent(input[[input$filter]], {
output$selected_filter_value <- renderUI({
textOutput("text_out")
})
output$text_out <- renderText({
paste0(input$filter, ": ", input[[input$filter]])
})
})
}
shinyApp(ui, server)
Well, I had to rearrange quite a lot and this whole problem is more about finding the right implementation for your case.
You can probably deduct most of it just looking at the code at the end of this post.
Main things explained: You didn't actually say what deleting means to you. So I just assumed you wanted the cells to not appear in the select boxes anymore. For that, I excluded NAs and replaced cells with an NA to show that they are deleted.
I rearranged the select values, such that we actually can delete certain cells, giving row and column names instead of just their values.
And most important, the buttons you wanted to create are dynamic UI elements with dynamic observers, which are then addressed to delete the certain cell.
Note: This solution is not optimal, since I specifically aimed to stay just on the R side of shiny. You can achieve a much more elegant and resource saving solution if you use JavaScript and shiny's custom messages.
Also: I did not address your request to let the selected values visible if the first select box changes. But this is a rather small issue, if you reconsider your setup. And I didn't want to diverge too much from you original code to not be confusing.
Code now:
library(shiny)
data <- data.frame(var1 = c("a", "b"), var2 = c("y", "z"))
ui <- fluidPage(
selectizeInput("filter", label = "Filter",
multiple = FALSE, choices = c("var1", "var2")),
uiOutput("filter_var"),
uiOutput("selected_filter_value")
)
server <- function(input, output) {
# Pulled out from original observeEvent
makeSecondInput <- function() {
output$filter_var <- renderUI({
# Names are not enough when wanting to delete data.frame rows (because of duplicates).
# So we instead use row numbers and set the actual values as labels.
choiceData <- na.exclude(data[input$filter])
choices <- rownames(choiceData)
names(choices) <- choiceData[, input$filter]
selectizeInput(input$filter, label = input$filter, selected = input[[input$filter]],
choices = choices, multiple = TRUE)
})
}
observeEvent(input$filter, {
makeSecondInput()
})
# Install a manual trigger to redraw input field, when an option is killed.
trigger <- reactiveVal()
observeEvent(trigger(), ignoreNULL = TRUE, {
makeSecondInput()
})
# Keep track of created observers, so dynamic creation does not wildly stack them up.
observersCreated <- character()
makeButtonObserver <- function(buttonname, colname, rowname) {
# For each delete-button created, install observer to delete data.frame cell.
observeEvent(input[[buttonname]], {
data[rowname, colname] <<- NA
# Force re-evaluation of observer above.
trigger(runif(1))
})
# Track that this button is equipped. (And re-creation of the same button does not add another obs.)
# Note: Observers DON'T get automagically removed after actionButton is no longer in the UI.
observersCreated <<- c(observersCreated, buttonname)
}
observeEvent(input[[input$filter]], {
output$selected_filter_value <- renderUI({
# Could be a list, so splitting that up.
lapply(input[[input$filter]], function(v) {
buttonname <- paste("kill", input$filter, v, sep = "_")
if (!(buttonname %in% observersCreated)) {
makeButtonObserver(buttonname, input$filter, v)
}
span(
paste0(input$filter, ": ", data[v, input$filter]),
actionButton(buttonname, "x")
)
})
})
})
}
shinyApp(ui, server)
This is what I currently have. There are still some issues which I couldn't solve.
Problems:
if I make some selections in input1, then switch from input1 to input2 and unclick one of the selections from input1 and then switch back to input1 these changes will be unmade
the checkboxes are rerendered when a new one is added and in this process sorted which changes the order
Code:
library(shiny)
library(shinyWidgets)
data <- data.frame(var1 = c("a", "b"), var2 = c("y", "z"))
ui <- fluidPage(
selectizeInput("filter", label = "Filter",
multiple = FALSE, choices = c("var1", "var2")),
uiOutput("filter_var"),
uiOutput("selected_filter_value")
)
server <- function(input, output, session) {
values <- reactiveValues(
filter_vals = list(var1 = list(), var2 = list()),
observers = NULL
)
# dynamically generate selectizeInput for variable selected in filter
# set selected values to previous selections
observeEvent(input$filter, {
output$filter_var <- renderUI({
selectInput(input$filter, label = input$filter,
selected = values$filter_vals[[input$filter]],
choices = data[input$filter], multiple = TRUE, selectize = TRUE)
})
})
# store selected values in list
observeEvent(input[[input$filter]], {
values$filter_vals[[input$filter]] <- input[[input$filter]]
})
# we need this because observeEvent is not triggered if input is empty after deleting all selections
observe({
if (is.null(input[[input$filter]])) {
values$filter_vals[[input$filter]] <- list()
}
})
# add an observer for newly created checkbox
# if checkbox is clicked delete entry in list
# keep a list of all existing observers
make_delete_observer <- function(name) {
observeEvent(input[[name]], {
req(input[[name]] == FALSE)
var <- stringr::str_split(name, "_")[[1]][1]
val <- as.integer(stringr::str_split(name, "_")[[1]][2])
values$filter_vals[[var]] <- intersect(values$filter_vals[[var]][-val],
values$filter_vals[[var]])
updateSelectInput(session, var, selected = values$filter_vals[[var]])
})
}
# render selected values which are stored in a list as checkboxes
# add an observeEvent for each checkbox
# store selected values in list
output$selected_filter_value <- renderUI({
req(values$filter_vals[[input$filter]])
req(any(sapply(values$filter_vals, length) > 0))
tag_list <- tagList()
for (i in seq_along(values$filter_vals)) {
for (j in seq_along(values$filter_vals[[i]])) {
new_input_name <- paste0(names(values$filter_vals)[i], "_", j)
new_input <- prettyCheckbox(
inputId = new_input_name, value = TRUE,
label = paste0(names(values$filter_vals)[i], ": ", values$filter_vals[[i]][j]),
icon = icon("close"), status = "danger", outline = FALSE, plain = TRUE
)
# create observer only if it does not exist yet
if (!(new_input_name %in% values$observers)) {
values$observers <- append(values$observers, new_input_name)
make_delete_observer(new_input_name)
}
tag_list <- tagAppendChild(tag_list, new_input)
}
}
tag_list
})
}
shinyApp(ui, server)
I'm developing a shiny app using reactive value, of course. However, I'd like to explore the use of reactiveValues to test my understanding of the concept. My design is to create a dt container of reactive values, e.g. data, cols, rows; so that I can save shiny input$file uploaded data to dt$data; also I'd use checkboxGroupInput to display the columns of the data, which is saved as dt$cols, and let users to select columns and then render data table of dt$data[dt$cols]. Here's the code I used:
dt <- reactiveValues()
observeEvent(input$uploadbutton, {
file <- input$file
req(input$file)
f <- read.csv(file$datapath, header = TRUE)
dt$data <- f
# get the col names of the dataset and assign them to a list
cols <- mapply(list, names(dt$data))
# update columns ui under columnscontrol div
updateCheckboxGroupInput(session, "columns", "Select Columns:", choices = cols, selected = cols)
})
observeEvent(input$columns, { dt$cols <- input$columns })
output$datatbl <- DT::renderDataTable(
dt$data[dt$cols], rownames = FALSE,
# column filter on the top
filter = 'top', server = TRUE,
# autoWidth
options = list(autoWidth = TRUE)
)
The code didn't work, I was thrown with the error of "undefined columns" when dt$data[dt$cols] is called. However, the above works fine if I only use reactive value dt2 <- eventReactive(input$columns, { f <- dt$data[input$columns], f }) and then call dt2() in renderDataTable(). I wonder what's wrong with the use of the variables in reactiveValues.
When you upload the file, the instruction dt$data <- f will then trigger the renderDataTable which uses dt$data. This happens before dt$cols <- input$columns is called therefore dt$colsis NULL and dt$data[dt$cols] throws an error.
You can try with isolate :
isolate(dt$data)[dt$cols]
When a row in a DataTable is clicked, I would like an image in a different panel to be loaded but, I keep getting an error and not.
**Warning in widgetFunc() :
renderDataTable ignores ... arguments when expr yields a datatable object; see ?renderDataTable
Error in basename(file) : a character vector argument expected**
output$image1 <- renderImage({
s = input$table1_rows_selected
if (length(s)) list(src=paste0(imagePath,"/peak",s,".png"))},deleteFile=FALSE)
The function below works however,
output$image1 <- renderImage({list(src=paste0(imagePath,"/peak1.png"))},deleteFile=FALSE)
Here is a full version of the code:
server.R
writeLines("Please select ANY image")
imagePath = file.choose()
# break up the character vector, delete the last word
imagePath = dirname(imagePath)
server = function(input, output) {
output$table1 = renderDataTable({
# the peak table
datatable(peaksTable,
# when rowname is false each row does not have a numeric # associated with it
rownames = FALSE,
# specify the name of the column headers
colnames = c("Seqnames", "Start", "End","Width","Strand","P","Q","Effectsize",
"FDR","Keep","Gene_name","Gene.nearest","Count","Count.pred",
"Coverage","Local.mut.density","Base.context.GC","Tn.Context.TpC",
"Tn.context.CpG","Dnase","Activechrom","Hetchrom","Rept"))
},
escape = FALSE)
# render an Image based on which rows are clicked on.
output$image1 <- renderImage({
s = input$table1_rows_selected
if (length(s)) list(src=paste0(imagePath,"/peak",s,".png"))},deleteFile=FALSE)
ui.R
shinyUI(navbarPage(
title = " Nanoproject",
# first panel , create table of the peaksTable dataframe
tabPanel('Peak Table' ,
dataTableOutput('table1')),
# second panel
tabPanel('Peak Images' ,
imageOutput("image1",width = "auto",height = "auto")
))
I'm not sure where I'm going wrong.
Like it's been pointed out, without a reproducible example it's hard to help.
My guess is that your code is not dealing with the case where no rows are selected. If that's true, something like this should fix the problem:
server.R
output$image1 <- renderImage({
s <- input$table1_rows_selected
# print(s)
if(is.null(s)) return(NULL)
list(src = paste0(imagePath,"/peak",s,".png"))
}, deleteFile=FALSE)
Printing out s could help you understand better whats going on.
I have created a datatable which has selectInput widgets in one of the columns. Another column of the datatable should take inputs given in the first column, and use them to look up a number from my data source. The inputs are binding correctly in Shiny, by using preDrawCallback and drawCallback functions, but lookup values are not updating when the inputs change. Strangely, they do update when I do the lookup in a separate data table. A reproducible example is here:
library(shiny)
library(DT)
data <- data.frame(c(1:7),c(21:27))
shinyApp(
server = shinyServer(function(input, output) {
output$table <- DT::renderDataTable({
Rows <- c(1:7)
temp <- data.frame(Rows)
temp[,"Item"] <- ""
temp[,"Value"] <- ""
temp$Rows <- NULL
sapply(1:7, FUN = function(i) {
temp$Item[i] <<- as.character(selectInput(paste("Item.1.1",i, sep = "."), "",
choices = setNames(c(1:7),c(1:7)),
selected = 1,
multiple = FALSE))
})
sapply(1:7, FUN = function(i) {
temp$Value[i] <<- data[eval(parse(text = paste("input$Item.1.1",i, sep = "."))),2]
})
datatable(temp, escape = FALSE, rownames = FALSE,
options = list(sort = FALSE, paging = FALSE, searching = FALSE, dom = 't',
columnDefs = list(list(className = 'dt-center', targets = 0:1)),
preDrawCallback = JS('function() { Shiny.unbindAll(this.api().table().node()); }'),
drawCallback = JS('function() { Shiny.bindAll(this.api().table().node()); } ')
))
}, server = FALSE)
}),
ui = fluidPage(
dataTableOutput("table")
)
)
That gives the error "Error in temp$Value[i] <<- data[eval(parse(text = paste("input$Item.1.1", :
replacement has length zero".
I have tried adding this to server:
test <- reactive({
data.frame(c(ifelse(is.null(input$Item.1.1.1),"",data[eval(parse(text = paste("input$Item.1.1",1, sep = "."))),2]),
ifelse(is.null(input$Item.1.1.2),"",data[input$Item.1.1.2,2]),
ifelse(is.null(input$Item.1.1.3),"",data[input$Item.1.1.3,2]),
ifelse(is.null(input$Item.1.1.4),"",data[input$Item.1.1.4,2]),
ifelse(is.null(input$Item.1.1.5),"",data[input$Item.1.1.5,2]),
ifelse(is.null(input$Item.1.1.6),"",data[input$Item.1.1.6,2]),
ifelse(is.null(input$Item.1.1.7),"",data[input$Item.1.1.7,2])))
})
Then, when I comment out the appropriate sapply within my renderDataTable and instead assign temp[,"Value"] <- test(), I get 21 down the second column of my datatable, and it does not change when the selectInputs are changed.
As a test, I have tried including this in my serve, coupled with a corresponding dataTableOutput() in my ui:
output$test1 <- DT::renderDataTable({
test()
})
test1 behaves as expected if and only if the second sapply is commented out inside of renderDataTable. If it is not commented out, both tables have a column of unresponsive 21s.
This has been driving me batty all day, so any thoughts would improve my life greatly!
You are using the select input values too early:
sapply(1:7, FUN = function(i) {
temp$Value[i] <<- data[eval(parse(text = paste("input$Item.1.1",i, sep = "."))),2]
})
By the time you use these values, the select inputs have not even been rendered on the page yet, so not surprisingly, you get NULL's. You cannot assign NULL to tmp$Value[i].
Then regarding the failure with:
temp[,"Value"] <- test()
I don't understand what this means: test() returns a data frame, and temp[, "Value"] is a vector. I think you should use c() instead of data.frame() in the reactive.
Something off-topic since I really cannot help it: it is almost always a bad idea to use eval(parse(text = ...)). You can just use input[paste("Item.1.1", i, sep = ".")] instead of constructing the R code and eval() it. Both input$foo and input['foo'] give you the value of the input with id foo. The latter form is more suitable in this case.