I want to store user inputs in shinyapp from DT in a data.frame. Here is what I have achieved by far.
library(shiny)
library(data.table)
library(DT)
shinyApp(
ui = fluidPage(
title = 'Radio buttons in a table',
DT::dataTableOutput('foo'),
verbatimTextOutput('sel'), verbatimTextOutput('x2')
),
server = function(input, output, session) {
x <- data.table( 'Breed Split' = paste0("F",rep(0:16)), Frisian = rep(1,17), Cross = rep(2,17), Jersey = rep(3,17) ,
checked=c(rep("Frisian",9),rep("Cross",5),rep("Jersey",3))
)
x[, Frisian := sprintf( '<input type="radio" name="%s" value="%s" %s/>', `Breed Split`, x[, Frisian],ifelse("Frisian"==x[, checked],"checked" ,""))]
x[, Cross := sprintf( '<input type="radio" name="%s" value="%s" %s/>', `Breed Split`, x[, Cross],ifelse("Cross"==x[, checked],"checked" ,"" ))]
x[, Jersey := sprintf( '<input type="radio" name="%s" value="%s" %s/>', `Breed Split`, x[, Jersey] ,ifelse("Jersey"==x[, checked],"checked" ,""))]
output$foo = DT::renderDataTable(
x[,-c("checked")], escape = FALSE, selection = 'none', server = FALSE, rownames=FALSE,
options = list(dom = 't', paging = FALSE, ordering = FALSE),
callback = JS("table.rows().every(function(i, tab, row) {
var $this = $(this.node());
$this.attr('id', this.data()[0]);
$this.addClass('shiny-input-radiogroup');
});
Shiny.unbindAll(table.table().node());
Shiny.bindAll(table.table().node());")
)
inputs <- reactive ({ str(sapply(x$`Breed Split`, function(i) input[[i]])) })
output$sel = renderPrint({ sapply(x$`Breed Split`, function(i) input[[i]]) })
}
)
What I want to achieve is the user input results in a data.frame like the following:
sel <- data.frame(id = paste0("F",rep(0:16)), input = c(rep(1,9), rep(2,5), rep(3,3) ))
WORKAROUND
I found the following workaround for the problem. It is working as desired, but I am getting a warning message though.
output$sel <- renderTable({
temp <- unlist(lapply(x$Breed, function(i) input[[i]]))
sel <<- data.frame(id = paste0("F",rep(0:16)), input = as.numeric(temp) )
return(sel)
})
##
Listening on http://127.0.0.1:5651
Warning: Error in data.frame: arguments imply differing number of rows: 17, 0
Stack trace (innermost first):
80: data.frame
79: renderTable [E:\R_workspace/app.R#36]
78: func
77: origRenderFunc
76: output$sel
1: runApp
Related
I want to add a choice row at the bottom of table. I searched for some answers but it included many other functions it was hard for me to understand.
library(shiny)
c1 <-c("Time in free flow (mins)",
"Time slowed down by other traffic (mins)",
"Percentage of total time spent with other vehicles close behind",
"Curviness",
"Running costs",
"Toll cost")
c2 <- c('50','10','25%','Moderate','$12.00','$0.00')
c3 <- c('38','5','31%','extreame','$10.50','$3.00')
c4 <- c('62','8','19%','Almost straight','$9.00','$0.50')
c5 <- c('56','15','12%','Moderate','$13.50','$0.00')
t <- cbind(c1,c2,c3,c4,c5)
ui <- fluidPage(
tableOutput("faith")
)
server <- function(input, output, session) {
output$faith <- renderTable({t}, type = "html", bordered = TRUE, striped = TRUE, align = "c")
}
shinyApp(ui = ui, server = server)
I updated some code based on the comments, but still don't know how to get the select value
library(shiny)
library(DT)
c1 <-c("Time in free flow (mins)",
"Time slowed down by other traffic (mins)",
"Percentage of total time spent with other vehicles close behind",
"Curviness",
"Running costs",
"Toll cost")
c2 <- c('50','10','25%','Moderate','$12.00','$0.00')
c3 <- c('38','5','31%','extreame','$10.50','$3.00')
c4 <- c('62','8','19%','Almost straight','$9.00','$0.50')
c5 <- c('56','15','12%','Moderate','$13.50','$0.00')
t <- cbind(c1,c2,c3,c4,c5)
tm <- c('<input type="radio" name="Dec" value="1"/>',
'<input type="radio" name="Dec" value="2"/>',
'<input type="radio" name="Dec" value="3"/>',
'<input type="radio" name="Dec" value="4"/>',
'<input type="radio" name="Dec" value="5"/>')
tmm <- rbind(t,tm)
shinyApp(
ui = fluidPage(
title = 'Radio buttons in a table',
DT::dataTableOutput('foo'),
verbatimTextOutput('sel')
),
server = function(input, output, session) {
output$foo = DT::renderDataTable(
tmm, escape = FALSE, selection = 'none', server = FALSE,
options = list(dom = 't', paging = FALSE, ordering = FALSE),
callback = JS("table.rows().every(function(i, tab, row) {
var $this = $(this.node());
$this.attr('id', this.data()[0]);
$this.addClass('shiny-input-radiogroup');
});
Shiny.unbindAll(table.table().node());
Shiny.bindAll(table.table().node());")
)
output$sel = renderPrint({
str(sapply('Dec', function(i) input[[i]]))
})
}
)
Any suggestion is welcome.
This is what I try to do. Add a single choice row.
I did it!
But still don't know how to submit the select value though observeEvent.
library(shiny)
library(DT)
library(googlesheets4)
c1 <-c("Time in free flow (mins)",
"Time slowed down by other traffic (mins)",
"Percentage of total time spent with other vehicles close behind",
"Curviness",
"Running costs",
"Toll cost")
c2 <- c('50','10','25%','Moderate','$12.00','$0.00')
c3 <- c('38','5','31%','extreame','$10.50','$3.00')
c4 <- c('62','8','19%','Almost straight','$9.00','$0.50')
c5 <- c('56','15','12%','Moderate','$13.50','$0.00')
t <- cbind(c1,c2,c3,c4,c5)
shinyApp(
ui = fluidPage(
title = 'Radio buttons in a table',
DT::dataTableOutput('foo'),
tt <- textOutput('sel')
textOutput('sel'),
actionButton("submit", "submit")
),
server = function(input, output, session) {
m = matrix(
as.character(1:4), nrow = 1, ncol = 4, byrow = TRUE,
dimnames = list(' ', LETTERS[1:4])
)
for (i in seq_len(nrow(m))) {
m[i, ] = sprintf(
'<input type="radio" name="%s" value="%s"/>',
' ', m[i, ]
)
}
m <- cbind('Chioce',m)
m<-rbind(t,m)
output$foo = DT::renderDataTable(
m, escape = FALSE, selection = 'none', server = FALSE,
options = list(dom = 't', paging = FALSE, ordering = FALSE),
callback = JS("table.rows().every(function(i, tab, row) {
var $this = $(this.node());
$this.attr('id', this.data()[0]);
$this.addClass('shiny-input-radiogroup');
});
Shiny.unbindAll(table.table().node());
Shiny.bindAll(table.table().node());")
)
output$sel = renderPrint({
str(sapply(' ', function(i) input[[i]]))
})
observeEvent(input$submit,{
})}
)
I made a select table with button in R shiny.
I want to add a submit actionButton to get the select value from DT::renderDataTable though observeEvent() function.
I have tried
observeEvent(input$submit,{
data <- data.frame(output$sel)}
This is not work.
Is it possible to get the value of callback?
The value can been see in the UI, but how can i get in server?
library(shiny)
library(DT)
library(googlesheets4)
c1 <-c("Time in free flow (mins)",
"Time slowed down by other traffic (mins)",
"Percentage of total time spent with other vehicles close behind",
"Curviness",
"Running costs",
"Toll cost")
c2 <- c('50','10','25%','Moderate','$12.00','$0.00')
c3 <- c('38','5','31%','extreame','$10.50','$3.00')
c4 <- c('62','8','19%','Almost straight','$9.00','$0.50')
c5 <- c('56','15','12%','Moderate','$13.50','$0.00')
t <- cbind(c1,c2,c3,c4,c5)
shinyApp(
ui = fluidPage(
title = 'Radio buttons in a table',
DT::dataTableOutput('foo'),
#tt <- textOutput('sel'),
textOutput('sel'),
actionButton("submit", "submit")
),
server = function(input, output, session) {
m = matrix(
as.character(1:4), nrow = 1, ncol = 4, byrow = TRUE,
dimnames = list(' ', LETTERS[1:4])
)
for (i in seq_len(nrow(m))) {
m[i, ] = sprintf(
'<input type="radio" name="%s" value="%s"/>',
' ', m[i, ]
)
}
m <- cbind('Chioce',m)
m<-rbind(t,m)
output$foo = DT::renderDataTable(
m, escape = FALSE, selection = 'none', server = FALSE,
options = list(dom = 't', paging = FALSE, ordering = FALSE),
callback = JS("table.rows().every(function(i, tab, row) {
var $this = $(this.node());
$this.attr('id', this.data()[0]);
$this.addClass('shiny-input-radiogroup');
});
Shiny.unbindAll(table.table().node());
Shiny.bindAll(table.table().node());")
)
output$sel = renderPrint({
str(sapply(' ', function(i) input[[i]]))
})
observeEvent(input$submit,{
})})
You can get the selected row indices (and work forward from there) like this:
ui <- fluidPage(
verbatimTextOutput('log'),
DTOutput('myTable')
)
server <- function(input, output) {
output$myTable <- renderDataTable(iris)
output$log <- renderPrint({
row_indices <- input$myTable_rows_selected
iris[row_indices,]
})
}
shinyApp(ui, server)
edit
You can set server input values via client side javascript.
In your case:
## [...]
for (i in seq_len(nrow(m))) {
m[i, ] = sprintf(
'<input type="radio" name="%s" value="%s"
// set input$selected to m[i,] when clicked:
onClick = "Shiny.setInputValue(\'selected\', %s)" />',
' ', m[i, ], m[i,]
)
}
## now input$selected will be updated upon selection of either radio input
## [...]
see: https://shiny.rstudio.com/articles/communicating-with-js.html
I am using datatable from DT library for user inputs from my Shinyapp.
Now I would like to color the background of the datatable cell based on user inputs.
Here is the code of what I have got so far:
library(shiny)
library(data.table)
library(DT)
shinyApp(
ui = fluidPage(
title = 'Radio buttons in a table',
DT::dataTableOutput('foo'),
verbatimTextOutput('sel'), verbatimTextOutput('x2')
),
server = function(input, output, session) {
x <- data.table( 'Breed Split' = paste0("F",rep(0:16)), Friesian = rep(1,17), Cross = rep(2,17), Jersey = rep(3,17) ,
checked=c(rep("Friesian",9),rep("Cross",5),rep("Jersey",3))
)
x[, Friesian := sprintf( '<input type="radio" name="%s" value="%s" %s/>', `Breed Split`, x[, Friesian],ifelse("Friesian"==x[, checked],"checked" ,""))]
x[, Cross := sprintf( '<input type="radio" name="%s" value="%s" %s/>', `Breed Split`, x[, Cross],ifelse("Cross"==x[, checked],"checked" ,"" ))]
x[, Jersey := sprintf( '<input type="radio" name="%s" value="%s" %s/>', `Breed Split`, x[, Jersey] ,ifelse("Jersey"==x[, checked],"checked" ,""))]
output$foo = DT::renderDataTable(
x[,-c("checked")], escape = FALSE, selection = 'none', server = FALSE, rownames=FALSE,
options = list(dom = 't', paging = FALSE, ordering = FALSE),
callback = JS("table.rows().every(function(i, tab, row) {
var $this = $(this.node());
$this.attr('id', this.data()[0]);
$this.addClass('shiny-input-radiogroup');
});
Shiny.unbindAll(table.table().node());
Shiny.bindAll(table.table().node());")
)
output$sel = renderPrint({ sapply(x$`Breed Split`, function(i) input[[i]]) })
}
)
Cell background color for selected breed:
Friesian: red
Cross: green
Jersey: blue
In other words, I need to apply formatStyle() within DT::renderDataTable
I have created a small example, where the background color of selected cells changes based on user input. I hope this helps!
server.R
library(shiny)
library(DT)
shinyServer(function(input, output, session) {
dataReactive <- reactive({
return(mtcars[mtcars$gear==input$gear,])
})
output$table1 <- DT::renderDataTable({
df <- head(mtcars,100)
if(input$gear==1) color="red"
if(input$gear==2) color="blue"
if(input$gear==3) color="green"
if(input$gear==4) color="lightblue"
DT::datatable(df) %>% formatStyle(c("mpg", "cyl", "disp"),
backgroundColor = color)
})
})
ui.R
shinyUI(fluidPage(
sidebarLayout(
sidebarPanel(
selectInput("gear","Select gear:", choices = c(1,2,3,4))
),
mainPanel(
DT::dataTableOutput("table1")
)
)
))
In my shinyapp, I wish to use data.table to get user inputs using radio buttons or check boxes and store the user inputs in a data.frame.
Here is what I have achieved so far:
library(shiny)
library(data.table)
library(DT)
shinyApp(
ui = fluidPage(
title = 'Radio buttons in a table',
DT::dataTableOutput('foo'),
verbatimTextOutput('sel')
),
server = function(input, output, session) {
x <- data.table( 'Breed Split' = paste0("F",rep(0:16)), Frisian = rep(1,17), Jersey = rep(2,17), Cross = rep(3,17) )
x[, Frisian := sprintf( '<input type="radio" name="%s" value="%s"/>', `Breed Split`, x[, Frisian] )]
x[, Jersey := sprintf( '<input type="radio" name="%s" value="%s"/>', `Breed Split`, x[, Jersey] )]
x[, Cross := sprintf( '<input type="radio" name="%s" value="%s"/>', `Breed Split`, x[, Cross] )]
output$foo = DT::renderDataTable(
x, escape = FALSE, selection = 'none', server = FALSE, rownames=FALSE,
options = list(dom = 't', paging = FALSE, ordering = FALSE),
callback = JS("table.rows().every(function(i, tab, row) {
var $this = $(this.node());
$this.attr('id', this.data()[0]);
$this.addClass('shiny-input-radiogroup');
});
Shiny.unbindAll(table.table().node());
Shiny.bindAll(table.table().node());")
)
output$sel = renderPrint({
str(sapply(x$`Breed Split`, function(i) input[[i]]))
})
}
)
And the other thing is if there is any way to set the default input values as shown in this screenshot.
[]
Try to add column of checked name and then remove column whe render DT
library(shiny)
library(data.table)
library(DT)
shinyApp(
ui = fluidPage(
title = 'Radio buttons in a table',
DT::dataTableOutput('foo'),
verbatimTextOutput('sel')
),
server = function(input, output, session) {
x <- data.table( 'Breed Split' = paste0("F",rep(0:16)), Frisian = rep(1,17), Jersey = rep(2,17), Cross = rep(3,17) ,
checked=c(rep("Frisian",9),rep("Jersey",5),rep("Cross",3))
)
x[, Frisian := sprintf( '<input type="radio" name="%s" value="%s" %s/>', `Breed Split`, x[, Frisian],ifelse("Frisian"==x[, checked],"checked" ,""))]
x[, Jersey := sprintf( '<input type="radio" name="%s" value="%s" %s/>', `Breed Split`, x[, Jersey],ifelse("Jersey"==x[, checked],"checked" ,"" ))]
x[, Cross := sprintf( '<input type="radio" name="%s" value="%s" %s/>', `Breed Split`, x[, Cross] ,ifelse("Cross"==x[, checked],"checked" ,""))]
output$foo = DT::renderDataTable(
x[,-c("checked")], escape = FALSE, selection = 'none', server = FALSE, rownames=FALSE,
options = list(dom = 't', paging = FALSE, ordering = FALSE),
callback = JS("table.rows().every(function(i, tab, row) {
var $this = $(this.node());
$this.attr('id', this.data()[0]);
$this.addClass('shiny-input-radiogroup');
});
Shiny.unbindAll(table.table().node());
Shiny.bindAll(table.table().node());")
)
output$sel = renderPrint({
str(sapply(x$`Breed Split`, function(i) input[[i]]))
})
}
)
Pretty much a copy paste from this example (which, I assume, supersedes some of the other answers on SO) except that I'm trying to use a data.table instead of a matrix. I'm unable to figure out why it isn't working.
library(shiny)
library(DT)
shinyApp(
ui = fluidPage(
title = 'Radio buttons in a table',
DT::dataTableOutput('foo'),
verbatimTextOutput('sel')
),
server = function(input, output, session) {
m = data.table(
month1 = month.abb,
A = '1',
B = '2',
C = '3',
QWE = runif(12)
)
m[, A := sprintf(
'<input type="radio" name="%s" value="%s"/>',
month1, m[, A]
)]
m[, B := sprintf(
'<input type="radio" name="%s" value="%s"/>',
month1, m[, B]
)]
m[, C := sprintf(
'<input type="radio" name="%s" value="%s"/>',
month1, m[, C]
)]
output$foo = DT::renderDataTable(
m, escape = FALSE, selection = 'none', server = FALSE,
options = list(dom = 't', paging = FALSE, ordering = FALSE),
callback = JS("table.rows().every(function(i, tab, row) {
var $this = $(this.node());
$this.attr('id', this.data()[0]);
$this.addClass('shiny-input-radiogroup');
});
Shiny.unbindAll(table.table().node());
Shiny.bindAll(table.table().node());")
)
output$sel = renderPrint({
str(sapply(month.abb, function(i) input[[i]]))
})
}
)
Issue is with rownames. You have an extra column of rownames that gets all the shiny attributes added to it, but it isn't a radio buttons it's just text so it breaks (although it should throw an error).
Here is a working version:
library(shiny)
library(DT)
shinyApp(
ui = fluidPage(
title = 'Radio buttons in a table',
DT::dataTableOutput('foo'),
verbatimTextOutput('sel')
),
server = function(input, output, session) {
m = data.table(
month1 = month.abb,
A = '1',
B = '2',
C = '3',
QWE = runif(12)
)
m[, A := sprintf(
'<input type="radio" name="%s" value="%s"/>',
month1, m[, A]
)]
m[, B := sprintf(
'<input type="radio" name="%s" value="%s"/>',
month1, m[, B]
)]
m[, C := sprintf(
'<input type="radio" name="%s" value="%s"/>',
month1, m[, C]
)]
output$foo = DT::renderDataTable(
m, escape = FALSE, selection = 'none', server = FALSE, rownames=FALSE,
options = list(dom = 't', paging = FALSE, ordering = FALSE),
callback = JS("table.rows().every(function(i, tab, row) {
var $this = $(this.node());
$this.attr('id', this.data()[0]);
$this.addClass('shiny-input-radiogroup');
});
Shiny.unbindAll(table.table().node());
Shiny.bindAll(table.table().node());")
)
output$sel = renderPrint({
str(sapply(month.abb, function(i) input[[i]]))
})
}
)