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.
Related
I have a simple shiny app with 2 datables.
#ui.r
navbarPage(
"Application",
tabPanel("General",
sidebarLayout(
sidebarPanel(
),
mainPanel(
DT::dataTableOutput("hot3"),
br(),
DT::dataTableOutput("hot5")
)
)))
#server.r
library(shiny)
library(DT)
server <- function(input, output,session) {
DF= data.frame(Sel. = rep(TRUE,2),
Label=paste("Test",as.integer(1:2)),
Marg=rep("Marg1",2),
Avail.=as.integer(rep.int(50,2)),
Sel =as.integer(rep.int(50,2)),
stringsAsFactors = FALSE)
output$hot3 <-DT::renderDataTable(
DF,
selection=list(mode="single", target="cell")
)
output$hot5 <-DT::renderDataTable({
DF = data.frame(
Sel= rep(TRUE, as.numeric(input$hot3_cells_selected)),
Id= 1:as.numeric(input$hot3_cells_selected),
Label=paste("Item",as.integer(1:as.numeric(input$hot3_cells_selected))),
Pf=as.integer(rep.int(0,as.numeric(input$hot3_cells_selected))),
stringsAsFactors = FALSE)
DF
})
}
What I want to achieve is when I click on the "Avail" cell (50) to create a new data frame with 50 rpws which will be displayed in a new data table.
but I take as error
Error in rep: invalid 'times' argument
This error is thrown by the rep function since you don't provide a valid times argument. In this case, input$hot3_cells_selected returns a vector representing the row and column indices of the selected cell, respectively. You can access the actual content of the cell using:
DF[input$hot3_cells_selected]
However, you need some additional adjustments to make your code more robust. For example, input$hot3_cells_selected is empty until a cell is selected, which will cause a similar problem with the rep function. Or, your should cover the case where a non-numeric cell is selected (i.e Test1 or Marg1). Below is a possible naïve solution:
# changing only this part of the code will be enough
# inserted DF[input$hot3_cells_selected] when needed below
output$hot5 <-DT::renderDataTable({
# checking whether any cell is selected or not
if(length(input$hot3_cells_selected) > 0) {
# checking whether the selected cell includes a number or not
# note that suppressWarnings is optional
if(!is.na(suppressWarnings(as.numeric(DF[input$hot3_cells_selected])))) {
# you don't need to store the data frame, so removed the assignment
# even if you wanna store it for future reference, use a unique name (not DF)
data.frame(
Sel= rep(TRUE, as.numeric(DF[input$hot3_cells_selected])),
Id= 1:as.numeric(DF[input$hot3_cells_selected]),
Label=paste("Item",as.integer(1:as.numeric(DF[input$hot3_cells_selected]))),
Pf=as.integer(rep.int(0,as.numeric(DF[input$hot3_cells_selected]))),
stringsAsFactors = FALSE
)
}
}
})
For testing, please upload a csv file with 1+ column that can be converted to Date in the app.
My app generates date range inputs (input$daterange) dynamically depending on the date columns selected. I'd like to validate each input$daterange from 1 to n (the length of dt$datecols) to make sure the user won't select start date earlier than the oldest date, and end date later than the latest date in the corresponding column. I use lapply on observeEvent to do that.
For ease of debugging, I pass the value of input$daterange(i) to reactive values dt$daterange(i) and print dt$daterange1 (the first date range's value) to the console rendered to check whether the it is smaller or bigger than the min and max of the corresponding date column, as I did in the lapply function. Supposedly, when the check result is FALSE, lappy function shall display an error message warning the user the start or end date is not valid, which, however doesn't work. Please find my code below, please check the comments for explanation of problem.
library("shiny")
library("DT") # Datatable
library("rsconnect") # deploy to shinyapps.io
library("shinyjs") # use toggle button from shinyJS pacakage
library("stats")
library("zoo") # to use as.Date() on numeric value
ui <- fluidPage(
fluidRow(
column(4,
# file upload div
fileInput("file", "Choose a file",
accept=c(
"text/csv",
"text/comma-separated-values,text/plain",
".csv"
)),
# show ui for upload file control
uiOutput("ui")
),
column(4,
# no choices before a file uploaded
uiOutput("columnscontrol")
)
),
hr(),
fluidRow(
column(4,
uiOutput("datecolscontrol")),
column(6,
uiOutput("daterangescontrol"))
),
hr(),
dataTableOutput("datatbl"),
# print console for debugging (delete after completion)
verbatimTextOutput("print_con")
) #end of fluidPage (ui)
# server
server <- function(input, output, session) {
#########################################################
# upload & datatable output
#########################################################
# create dataset reactive objects
dt <- reactiveValues()
# reset all uis upon new file upload
observeEvent(input$file, {
# reset reactive values
dt$data = NULL
dt$df = NULL
dt$cols = NULL
dt$rows = NULL
dt$summary = NULL
dt$colchoices = NULL
dt$datecols = NULL
# remove columns div and datecols div when a new file uploaded
removeUI(selector = "div#columns_div")
removeUI(selector = "div#datecols_div")
# remove all <div> elements indside <div>#daterangescontrol:
removeUI(selector = "div#daterangescontrol div")
# generate upload file control ui once file uploaded
output$ui <- renderUI({
actionButton("readF", "Update")
})
})
# when read file button pressed:
observeEvent (input$readF, {
# store data to dt$data
file <- input$file
dt$data <- read.csv(file$datapath, header = TRUE)
# render columnscontrol
output$columnscontrol <- renderUI({
# get the col names of the dataset and assign them to a list
dt$colchoices <- mapply(list, names(dt$data))
# render column group checkbox ui after loading the data
# tags#div has the advantage that you can give it an id to make it easier to reference or remove it later on
tags$div(id = "columns_div",
checkboxGroupInput("columns", "", choices = NULL, selected = NULL))
})
# render div containing #datecols under datecolscontrol
output$datecolscontrol <- renderUI({
tags$div(id = "datecols_div",
selectInput("datecols", "Filter data by dates):", choices = NULL, multiple = TRUE, selected = NULL))
})
})
# update columns choices when dt$choices is ready
observeEvent(dt$colchoices, {
updateCheckboxGroupInput(session, "columns", "Select Columns:", choices = dt$colchoices, selected = dt$colchoices)
})
# the other reactivity on dt$cols is input$file (when new file uploaded, dt$data and dt$cols set to NULL)
# so that the following line set apart the reactivity of input$columns on dt$cols
observeEvent(input$columns, {
dt$cols <- input$columns
dt$df <- dt$data[dt$cols]
}, ignoreNULL = FALSE)
# upon any change of dt$df
observeEvent(dt$df, {
f <- dt$df
# render output$datatbl
output$datatbl <- DT::renderDataTable(
f, rownames = FALSE,
filter = 'top',
options = list(autoWidth = TRUE)
)
# update datecols choices with those columns can be converted to Date only:
dt$date_ok = sapply(f, function(x) !all(is.na(as.Date(as.character(x), format = "%Y-%m-%d"))))
dt$datecolchoices = colnames(f[dt$date_ok])
updateSelectInput(session, "datecols", "Filter data by dates:", choices = dt$datecolchoices, selected = NULL)
}, ignoreNULL = FALSE)
# whenver columns convertable to date updated to choices of input$datecols, convert the columns to Date in the dataset
observeEvent(dt$datecolchoices, {
dt$df[dt$date_ok] = lapply(dt$df[dt$date_ok], function(x) as.Date(as.character(x)))
})
# generate daterange uis per selected input$datecols
observeEvent(input$datecols, {
dt$datecols = input$datecols
dt$datecols_len = length(dt$datecols)
# render daterange ui(s) per selected datecols
output$daterangescontrol <- renderUI({
# when input$datecols is NULL, no daterange ui
if ( is.null(input$datecols) ) { return(NULL) }
# otherwise
else {
D = dt$df[dt$rows, dt$cols]
output = tagList()
for (i in 1:dt$datecols_len) {
output[[i]]= tagList()
output[[i]][[1]] = tags$div(id = paste("dateranges_div", i, sep = "_"),
dateRangeInput(paste0("daterange", i),
paste("Date range of", dt$datecols[[i]]),
start = min(D[[dt$datecols[[i]]]]),
end = max(D[[dt$datecols[[i]]]])))
}
# return output tagList() with ui elements
output
}
}) # end of renderUI
}, ignoreNULL = FALSE)
# loop observeEvent to check whether each input$daterange is valid:
#### why I can't just call lapply() without observe() as suggested in this post:
#### https://stackoverflow.com/questions/40038749/r-shiny-how-to-write-loop-for-observeevent
observe({
lapply( X = 1:dt$datecols_len,
FUN = function(i) {
observeEvent(input[[paste0("daterange", i)]], {
# update reactive values to test whether this loop is working
dt[[paste0("range",i)]] = input[[paste0("daterange", i)]]
range = dt[[paste0("range",i)]]
req(range)
#########################################
## CODE BLOCK WITH PROBLEM!!!
#########################################
# Why the following doesn't work, when I pick a date earlier than the oldest date
# no error message shows!
shiny::validate(
need( range[[1]] >= min(dt$df[[dt$datecols[[i]]]]), "The start date cannot be earlier than the oldest date!"),
need( range[[2]] <= max(dt$df[[dt$datecols[[i]]]]), "The end date cannot be later than the latest date!")
)
})
}
) # end of lapply
})
# rows displayed in input$datatbl (the rendered data table)
observeEvent( input$datatbl_rows_all, {
dt$rows <- input$datatbl_rows_all
})
#########################################################
# print console
#########################################################
output$print_con <- renderPrint({
req(input$daterange1)
list(
# to verify whether the observeEvent loop is working for input validation
# I used dt$range1 to check the first (input$daterange1) against the date range of the corresponding column of the dataset.
# It's supposed that when the check result is FALSE (either by selecting a start date earlier than the oldest date or selecting an end date later than the latest date),
# the code block with problem shall prompt an error message to warn the user
min(dt$range1) >= min(dt$df[[dt$datecols[[1]]]]),
max(dt$range1) <= max(dt$df[[dt$datecols[[1]]]])
)
})
} # end of shiny server function
shinyApp(ui = ui, server = server)
This may not be the exact answer you are looking for but I think it may simplify things. I would simply order your date column which would allow you to select the oldest and newest date. Then set your start and end dates to those two values (see ?dateRangeInput). Lubridate is also a great package for working with dates
I think the problem maybe related to the format of your dates.
please look at this post:
R: Shiny dateRangeInput format
you may need to use
format(range[[1]])
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]
I am trying to make a basic program in R shiny framework so that I can display an interactive data table. The basic function I need to perform but can't is getting the row and column index of any selected/clicked cell. I have done research online and followed the tutorials exactly, but what is shown in the tutorials does not appear to be working. Since I think getting clicks is harder, I have settled with getting the row and column index of whatever cell is selected. Here is what I currently have for the ui.R and server.R files:
library(shiny)
library(shinyTable)
library(DT)
server <- function(input, output, session) {
lastTransToMat = data.table(cbind(c(.5,.5),c(.8,.2)))
output$transtable = DT::renderDataTable(lastTransToMat,options = list(target = 'column+row'))
output$response <-DT::renderDataTable({
rows= as.numeric(input$transtable_rows_selected)
cols = as.numeric(input$transtable_columns_selected)
print(rows)
print(cols)
response = data.table(cbind(c(paste0("rows: ",rows),c(paste0("cols: " ,cols)))))
print(response)
return(response)
})
}
shinyUI(fluidPage(
titlePanel("transition table"),
mainPanel(
DT::dataTableOutput('transtable'),
DT::dataTableOutput('response')
)
))
When I runApp() on this, I am only able to get the index of the row, but not the index of the column. See output below:
numeric(0)
V1
1: rows: 1
2: cols:
There is a similar data.table output in the shiny app itself.
Does anyone know why this is happening?
How can I get both the row and column index of a selection? And what about clicks?
Best,
Paul
EDIT:
As per user5029763's suggestion, I replaced my server.R function with the following:
#ui.R
library(shiny)
library(shinyTable)
library(DT)
shinyUI(fluidPage(
titlePanel("transition table"),
mainPanel(
DT::dataTableOutput('transtable'),
DT::dataTableOutput('response'),
htmlOutput('response2')
)
))
#server.R
server <- function(input, output, session) {
lastTransToMat = data.table(cbind(c(.5,.5),c(.8,.2)))
output$transtable = DT::renderDataTable(lastTransToMat,server = F,options = list(target = 'cell'))
output$response <-DT::renderDataTable({
cell= as.numeric(input$transtable_cell_clicked)
print(cell)
response = data.table(cbind(c(paste0("cell: "),c(paste0(cell)))))
print(response)
return(response)
})
output$response2 <- renderUI({
cells <- input$transtable_cell_clicked
if(length(cells) == 0) return( div('No cell is selected') )
cells <- data.frame(cells)[-3]
response <- paste0(c('Row', 'Column'), ': ', cells, collapse = ' / ')
div(response)
})
}
Output before any click:
Output after click/selection:
Is this the same as the output you get when you runApp() on this?
EDIT: Also just FYI, I tried this on another computer with the most updated version of R and got the same output, so I don't think it has to do with my version/computer.
If what you want is to get the index of clicked cells you could go with:
output$transtable = DT::renderDataTable(
lastTransToMat,
server = F,
selection = list(target = 'cell')
)
Then, input$transtable_cell_clicked will be a list with row/column index and the value within the cell. Just remember that the column index starts at 0.
EDIT: one way to print out
#server.R
output$response2 <- renderUI({
cells <- input$transtable_cell_clicked
if(length(cells) == 0) return( div('No cell is selected') )
cells <- data.frame(cells)[-3]
response <- paste0(c('Row', 'Column'), ': ', cells, collapse = ' / ')
div(response)
})
#ui.R
htmlOutput('response2')
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.)