I have a number of numericInputs put into several columns of a DT datatable. I would like to allow users to click a button, which then copies inputs from the first column to the other columns. I'm able to make this work for numericInputs that are not part of a datatable, but nothing happens to numericInputs inside of a datatable. A simplified example of my problem is given below. I also include a working example for a standalone numericInput, which is not part of a datatable, to demonstrate the behavior I'm looking for.
library(shiny)
library(DT)
shinyApp(
server = shinyServer(function(input, output, session) {
output$Table <- DT::renderDataTable({
observeEvent(input$button1, {
v <- input$Number.1.1
updateNumericInput(session,"Number.2.1", value = v)
})
temp <- data.frame(c(1:5))
temp$Numbers.1 <- ""
temp$Numbers.2 <- ""
sapply(1:5, FUN = function(i){
temp$Numbers.1[i] <<- as.character(numericInput(paste0("Number.1.", i), "", value = NULL, min = 0, max = 10, step = 0.01))
})
sapply(1:5, FUN = function(i){
temp$Numbers.2[i] <<- as.character(numericInput(paste0("Number.2.", i), "", value = NULL, min = 0, max = 10, step = 0.01))
})
datatable(temp,escape = FALSE, rownames = FALSE, options = list(sort = FALSE, paging = FALSE, searching = FALSE))
})
observeEvent(input$button2,{
v <- input$Number.3
updateNumericInput(session,"Number.4", value = v)
})
}),
ui = fluidPage(
br(),
actionButton("button1","Copy"),
dataTableOutput("Table"),
br(),
actionButton("button2","Copy"),
numericInput("Number.3", "Number 3", value = NULL, min = 0, max = 10, step = 0.1),
numericInput("Number.4", "Number 4", value = NULL, min = 0, max = 10, step = 0.1)
)
)
I have also tried placing the observeEvent outside of the renderDataTable, but that was no help. Since the button works fine for standalone numericInputs, I'm guessing this is some sort of scoping issue, but I've been unable to figure out how to resolve it.
Thanks in advance for any help!
I solved my problem. (It turns out I actually knew the answer, but was having a brain fart.) The datatable() function inside of renderDataTable({}) should read:
datatable(temp,escape = FALSE, rownames = FALSE, options = list(sort = FALSE, paging = FALSE, searching = FALSE,
preDrawCallback = JS('function() { Shiny.unbindAll(this.api().table().node()); }'),
drawCallback = JS('function() { Shiny.bindAll(this.api().table().node()); } ')))
Related
I have a small rshiny app, in which i can select row in datatable and get values from first columns.
but how to quickly get rid of the selected rows and values without clicking on the row again?
also if you know what can be improved in this code, then write, I just started coding in R
# Define UI
ui <- fluidPage(
dataTableOutput('main_information'),
fluidRow(
column(8,verbatimTextOutput('selected_rows', placeholder = TRUE)),
fluidRow(
column(4,actionButton("reset", "RESET"))
)
)
)
# Define server function
server <- function(input, output,session) {
getScoreTable<-reactive({
db <- dbConnect(SQLite(), "path")
data <- dbGetQuery(
conn = db,
statement =
'...'
)
})
output$main_information <- renderDataTable(
getScoreTable(),
options = list(
pageLength = 5,
lengthMenu = list(c(5,10, 25, 50, 100),
c('5', '10', '25','50', '100'))
)
)
s<-reactiveValues(data= NULL)
output$selected_rows = renderPrint({
s = input$main_information_rows_selected
if (length(s)) {
cat('These values were selected:\n\n')
cat(getScoreTable()[s,1], sep = '\n')
}else{
cat('No value has been selected')
}
})
}
# Create Shiny object
shinyApp(ui = ui, server = server)
You can use a custom action button:
library(DT)
js <- "
function ( e, dt, node, config ) {
dt.rows().deselect();
}
"
datatable(
iris,
extensions = c("Buttons", "Select"),
selection = "none",
options = list(
"dom" = "Bfrtip",
"select" = TRUE,
"buttons" = list(
list(
"extend" = "collection",
"text" = "DESELECT",
"action" = JS(js)
)
)
)
)
This example works fine. If you have an issue in Shiny, please provide a minimal reproducible code, not using SQL.
I need to pass filtration from configuration file to datatable. When the table is rendered the user must be able to clean the filtration and see the full content of the table
The problem arises when the filtration is applied to factor columns. In this case the content of the table is rendered but is not shown in the table. It is necessary click additionally on the filter and choose another value. But it still works fine with character columns. How one may fix it?
There is an example which reproduce my problem.
library(shiny)
library(DT)
ui <- fluidPage(
fluidRow(
selectInput(inputId = "table_fltration",
label = 'Choose table filtration',
choices = c("Working example",
"Not working example"),
selected = "Working example"),
actionButton(inputId = 'update_btn', label = "Use config")),
fluidRow(dataTableOutput("iris_table"))
)
server <- function(input, output, session) {
columns_search <- reactive({
if (input$table_fltration == "Working example") {
ex <- c("7.2 ... 7.9", "", "", "", "", "[\"anything\"]")
} else {
ex <- c("", "", "", "", "[\"anything\"]", "")
}
columns_search <- list()
for ( i in 1:length(ex)) {
if(ex[i] != "") {
element = list(list(search = ex[i]))
} else {element = NULL}
columns_search[i] <- element
}
columns_search
})
iris_table_ex <- reactive({
iris$Species_2 = as.character(iris$Species)
iris
})
observeEvent(input$update_btn,
output$iris_table <- DT::renderDataTable({
DT::datatable(iris_table_ex(),
filter = list(position = 'top'),
class = 'hover',
rownames = FALSE,
options = list(orderClasses = TRUE,
stateSave = FALSE,
searchHighlight = TRUE,
searchCols = columns_search(),
scrollX = TRUE,
paging = TRUE,
pageLength = 10))
})
)
}
shinyApp(ui, server)
I am building a shiny app with a timeline and a data table. What I would like to have happen is when the user clicks on an item in the timeline, the corresponding data in the table is highlighted.
I have come up with a solution for this, but it seems very hacky and R is giving me warning messages. Basically what I have done is created a flag in the data table that is 1 if that item is selected and 0 if it's not, then I format the row based on that flag. When I create the "selected" field, I get a warning because initially nothing is selected and mutate doesn't like the fact that input$timeline_selected is NULL. Also for some reason when I try to add the rownames = FALSE argument to datatable all the data in the table is filtered out (not sure what is happening there).
Anyway, I'm wondering if there is a better way to do this perhaps with HTML or CSS. I've tried looking, but I can't figure out how to do it.
Eventually I would also like to know how to highlight the rows in the data table if the user hovers over the item in the timeline rather than selects it.
library(shiny)
library(DT)
library(dplyr)
dataBasic <- data.frame(
id = 1:4,
content = c("Item one", "Item two" ,"Ranged item", "Item four"),
start = c("2016-01-10", "2016-01-11", "2016-01-20", "2016-02-14"),
end = c(NA, NA, "2016-02-04", NA)
)
ui <- fluidPage(
column(wellPanel(timevisOutput("timeline")
), width = 7
),
column(wellPanel(dataTableOutput(outputId = "table")
), width = 5)
)
server <- function(input, output){
# Create timeline
output$timeline <- renderTimevis({
config <- list(
orientation = "top",
multiselect = TRUE
)
timevis(dataBasic, options = config)
})
output$table <- DT::renderDataTable({
input$timeline_data %>%
mutate(selected = if_else(id %in% input$timeline_selected, 1, 0)) %>%
datatable(options = list(pageLength = 10,
columnDefs = list(list(targets = 5, visible = FALSE))
)
) %>%
formatStyle("selected", target = "row", backgroundColor = styleEqual(c(0, 1), c("transparent", "#0092FF"))
)
})
}
shinyApp(ui = ui, server = server)
Using Your Code
Your method certainly works -- it's similar to this answer. You could prevent some of the error messages by using if...else and a validation statment:
output$table <- DT::renderDataTable({
validate(need(!is.null(input$timeline_data), ""))
if(is.null(input$timeline_selected)) {
input$timeline_data %>%
datatable(
rownames = FALSE,
options = list(pageLength = 10))
} else {
input$timeline_data %>%
mutate(selected = if_else(id %in% input$timeline_selected, 1, 0)) %>%
datatable(rownames = FALSE,
options = list(pageLength = 10,
columnDefs = list(list(targets = 4, visible = FALSE))
)
) %>%
formatStyle("selected", target = "row", backgroundColor = styleEqual(c(0, 1), c("transparent", "#0092FF"))
)
}
})
I believe your issue with adding rownames = FALSE is because columnDefs uses JS indexing instead of R indexing. R indexes start at 1, whereas JS indexes start at 0.
When rownames = TRUE, your table has column indexes 0-5, where rownames is column 0 and selected is the column 5. So columnDefs works. However, when rownames = FALSE, you only have column indexes 0-4, so targets = 5 is outside the index range of your table. If you change your code to targets = 4, then you will again be specifying the selected column in columnDefs.
Other Options
Here's two other options using JS:
Generate the table on the server-side, as based on this answer. This may be a better option for large data objects.
Generate the table on the client-side as based on this answer. With a smaller object, this seems to update more smoothly.
An example app with both tables is below.
Example Code
library(shiny)
library(DT)
library(dplyr)
library(timevis)
dataBasic <- data.frame(
id = 1:4,
content = c("Item one", "Item two" ,"Ranged item", "Item four"),
start = c("2016-01-10", "2016-01-11", "2016-01-20", "2016-02-14"),
end = c(NA, NA, "2016-02-04", NA)
)
ui <- fluidPage(
column(wellPanel(timevisOutput("timeline")
), width = 7
),
column(
wellPanel(
h3("Client-Side Table"),
DT::dataTableOutput("client_table"),
h3("Server-Side Table"),
DT::dataTableOutput("server_table")
), width = 5)
)
server <- function(input, output, session){
# Create timeline
output$timeline <- renderTimevis({
config <- list(
orientation = "top",
multiselect = TRUE
)
timevis(dataBasic, options = config)
})
## client-side ##
# based on: https://stackoverflow.com/a/42165876/8099834
output$client_table <- DT::renderDataTable({
# if timeline has been selected, add JS drawcallback to datatable
# otherwise, just return the datatable
if(!is.null(input$timeline_selected)) {
# subtract one: JS starts index at 0, but R starts index at 1
index <- as.numeric(input$timeline_selected) - 1
js <- paste0("function(row, data) {
$(this
.api()
.row(", index, ")
.node())
.css({'background-color': 'lightblue'});}")
datatable(dataBasic,
rownames = FALSE,
options = list(pageLength = 10,
drawCallback=JS(js)))
} else {
datatable(dataBasic,
rownames = FALSE,
options = list(pageLength = 10))
}
}, server = FALSE)
## server-side ##
# based on: https://stackoverflow.com/a/49176615/8099834
output$server_table <- DT::renderDataTable({
# create the datatable
dt <- datatable(dataBasic,
rownames = FALSE,
options = list(pageLength = 10))
# if timeline has been selected, add row background colors with formatstyle
if(!is.null(input$timeline_selected)) {
index <- as.numeric(input$timeline_selected)
background <- JS(paste0("value == '",
index,
"' ? 'lightblue' : value != 'else' ? 'white' : ''"))
dt <- dt %>%
formatStyle(
'id',
target = 'row',
backgroundColor = background)
}
# return the datatable
dt
})
}
shinyApp(ui = ui, server = server)
I am trying to set custom values for shiny slider (1,5,10,15,20,25 and 30). I tried step but then the results either (0,5,10,15,20,25,30) or (1,6,11,16,21,26,31). Is there any way yo define custom values for slider?
Thanks!
plotpath <- "/Volumes/share-ites-1-$/Projects/Scientifica/Simulations_Scientifica"
ui <- fluidPage(
titlePanel("LandClim Simulations"),
sidebarLayout(
sidebarPanel(
sliderInput(inputId = "temp",
label = "Temperature increase:",
value = 1, min = 1, max = 2,
step = 1, animate = TRUE ),
sliderInput(inputId = "prec",
label = "Precipitation change:",
value = 0, min = -2, max = 2,
step = 1, animate = TRUE ),
sliderInput(inputId = "decade",
label = "Time (decade):",
value = 1, min = 0, max = 30,
step = 5, animate = TRUE )
),
mainPanel(imageOutput("image"))
)
)
server <- function(input, output) {
output$image <- renderImage( deleteFile = FALSE, {
return(list(
src = paste(plotpath,"/Temp",input$temp,"Prec",input$prec,"Dec",input$decade,".png",sep = ""),
contentType = "image/png"))
} ) }
shinyApp(ui = ui, server = server)
The shinyWidgets package now solves this for you with a slider that allows custom values. Updated code for your third slider would look like this:
shinyWidgets::sliderTextInput(inputId = "decade",
label = "Time (decade):",
choices = c(1,5,10,15,20,25,30))
Although Shiny gives options to customize the slider Input,I do not think there is a way to to get output in the form (1,5,10...).This is because the difference between your 1st and 2nd point is 4 and thereafter it is 5 which will be inconsistent with the way step parameter works.Step can only generate numbers based on constant differences between slider inputs.
Depending on the need to have a slider, to have inputs with variable breaks you could use one of the other options, like
selectInput
https://shiny.rstudio.com/reference/shiny/latest/selectInput.html
or even checkboxInput
https://shiny.rstudio.com/reference/shiny/latest/checkboxInput.html
This can be easily done using sliderTextInput function in shiny. No need to add all this complex js function. Just a few lines of code will do the trick.Install the shinywidgets package which contains the sliderTextInput function. Do the following :
sliderTextInput("decade","Time (decade):,
choices = c(1,5,10,15,20,25,30),
selected = c(1,5,10,15,20,25,30),
animate = FALSE, grid = FALSE,
hide_min_max = FALSE, from_fixed = FALSE,
to_fixed = FALSE, from_min = NULL, from_max = NULL, to_min = NULL,
to_max = NULL, force_edges = FALSE, width = NULL, pre = NULL,
post = NULL, dragRange = TRUE)
In my shiny app I have a dynamic input using renderUI.
This works very well, and another part of the program captures the input of the sliders.
When the application changes of status (e.g. when the button "update model" is pressed) I still need to display / use sliders with similar labels but as they are "new" the value needs to be re-initialised to zero.
The problem is that the sliders have a memory. If I re-use the same inputId
paste0(Labv[i], "_v",buttn)
shiny will have the old value associated to it.
Currently my code is using the variable buttn to bypass the problem: every time the status changes I create "new" sliders.
On the other hand the more the users will use the app, the more garbage will be collected into shiny.
I tried to use renderUI to send the list of elements to NULL, experimenting with sending a list of
updateTextInput(session, paste0(lbs[i],"_v",buttn),
label = NULL, value = NULL )
or tags$div("foo", NULL) but in each case the actual variable was rendered as text, which is worst!
# Added simplified example
library(shiny)
library(data.table)
#
dt_ = data.table( Month = month.abb[1:5],
A=rnorm(5, mean = 5, sd = 4),
B=rnorm(5, mean = 5, sd = 4),
C=rnorm(5, mean = 5, sd = 4),
D=rnorm(5, mean = 5, sd = 4),
E=rnorm(5, mean = 5, sd = 4))
dt_[,id :=.I]
dt <- copy(dt_)
setkey(dt_, "Month")
setkey(dt, "Month")
shinyApp(
ui = fluidPage(
fluidRow(
column(4,
actionButton("saveButton", "Update Model"))),
fluidRow(
column(6, dataTableOutput('DT')),
column(3, br(),br(),checkboxGroupInput("pick",h6("Picker"),
month.abb[1:5])),
column(3, uiOutput('foo'))),
fluidRow(
column(4, verbatimTextOutput('vals')))
),
server = function(session,input, output) {
valPpu <- reactiveValues()
valPpu$buttonF <- 1
valPpu$dt_ <- dt_
##
output$DT <- renderDataTable({
if(length(input$pick) > 0 ) {
# browser()
isolate( { labs <- input$pick } ) #
buttn <- valPpu$buttonF
iter <- length(labs)
valLabs <- sapply(1:iter, function(i) {
as.numeric(input[[paste0(labs[i],"_v",buttn)]]) })
if( iter == sum(sapply(valLabs,length)) ) {
cPerc <- valLabs
cPerc <- as.data.table(cPerc)
cPercDt <- cbind(Month=labs,cPerc)
ival <- which(dt[["Month"]]
%in% cPercDt[["Month"]])
setkey(cPercDt, "Month")
for(j in LETTERS[1:5]) set(dt_, i=ival,
j=j, dt[cPercDt][[j]] * (1 + dt_[cPercDt][["cPerc"]]) )
valPpu$dt_ <- dt_
} }
dt_[order(id),]
}, options = list(
scrollX = TRUE,
scrollY = "250px" ,
scrollCollapse = TRUE,
paging = FALSE,
searching = FALSE,
ordering = FALSE )
)
##
output$foo <- renderUI({
if(is.null(input$saveButton)) { return() }
if(length(input$pick) > 0 ) {
labs <- input$pick
iter <- length(labs)
buttn <- isolate(valPpu$buttonF )
valLabs <- sapply(1:iter, function(i) {
if(is.null(input[[paste0(labs[i],"_v",buttn)]] )) {
0
} else { as.numeric(input[[paste0(labs[i],"_v",buttn)]]) }
})
#
toRender <- lapply(1:iter, function(i) {
sliderInput(inputId = paste0(labs[i], "_v",buttn),
label = h6(paste0(labs[i],"")),
min = -1,
max = 1,
step = 0.01,
value = valLabs[i],
# format = "##0.#%",
ticks = FALSE, animate = FALSE)
})
toRender
}
})
observe({
if(is.null(input$saveButton)) { return() }
if(input$saveButton < valPpu$buttonF) { return() }
valPpu$buttonF <- valPpu$buttonF + 1
dt <<- valPpu$dt_
# TODO: add proper saving code
})
}
)
In the actual app the checkboxGroupInput is also driven from the server with renderUI and is reset when the "update model" is pressed. Also, there are more "events" in the UI that I haven't added to the code.
Any idea?
So your current approach actually works. FWIW, the sliders have been removed from HTML, so you do not need to worry about that. For the old values stored in input, such as input[['Jan_v1']] when the button has been clicked twice (and you only need input[['Jan_v2']]), I do not see why you care so much about them unless your total memory is less than a few kilobytes, because you only need a few bytes to store these values. It is probably true that you cannot remove these values from input, but I'd suggest you not spend time on this issue until it becomes a real problem.