Suppose I have the following shiny app:
library(shiny)
library(rhandsontable)
ui <- shinyUI(fluidPage(
titlePanel("Handsontable"),
sidebarLayout(
sidebarPanel(
helpText("Handsontable demo output. Column add/delete does work ",
"for tables with defined column properties, including type."),
radioButtons("useType", "Use Data Types", c("TRUE", "FALSE"))
),
mainPanel(
rHandsontableOutput("hot", width = 350)
)
)
))
server <- shinyServer(function(input, output, session) {
values = reactiveValues()
data = reactive({
if (!is.null(input$hot)) {
DF = hot_to_r(input$hot)
} else {
if (is.null(values[["DF"]]))
DF = data.frame(val = 1:10, bool = TRUE, nm = LETTERS[1:10],
dt = seq(from = Sys.Date(), by = "days", length.out = 10),
stringsAsFactors = F)
else
DF = values[["DF"]]
}
values[["DF"]] = DF
DF
})
output$hot <- renderRHandsontable({
DF = data()
if (!is.null(DF))
rhandsontable(DF, useTypes = as.logical(input$useType), stretchH = "all")
})
})
# Run the application
shinyApp(ui = ui, server = server)
How can I disable editing for the first two columns?
The whole table and individual columns can to set to readOnly to prevent the user from making changes.(http://jrowen.github.io/rhandsontable/#read-only)
library(shiny)
library(rhandsontable)
ui <- shinyUI(fluidPage(
titlePanel("Handsontable"),
sidebarLayout(
sidebarPanel(
helpText("Handsontable demo output. Column add/delete does work ",
"for tables with defined column properties, including type."),
radioButtons("useType", "Use Data Types", c("TRUE", "FALSE"))
),
mainPanel(
rHandsontableOutput("hot", width = 350)
)
)
))
server <- shinyServer(function(input, output, session) {
values = reactiveValues()
data = reactive({
if (!is.null(input$hot)) {
DF = hot_to_r(input$hot)
} else {
if (is.null(values[["DF"]]))
DF = data.frame(val = 1:10, bool = TRUE, nm = LETTERS[1:10],
dt = seq(from = Sys.Date(), by = "days", length.out = 10),
stringsAsFactors = F)
else
DF = values[["DF"]]
}
values[["DF"]] = DF
DF
})
output$hot <- renderRHandsontable({
DF = data()
if (!is.null(DF))
rhandsontable(DF, useTypes = as.logical(input$useType), stretchH = "all") %>%
hot_col("val", readOnly = TRUE) %>%
hot_col("bool",readOnly = TRUE )
})
})
# Run the application
shinyApp(ui = ui, server = server)
Related
I'm trying to insert a reactive value, from a separate user input, into a table rendered using rhandsontable. An example code is posted at the bottom of this post. Immediately below is an image that best explains what I'm trying to do. Any recommendations for how to do this?
Code:
library(rhandsontable)
library(shiny)
library(shinyjs)
mydata <- data.frame('Series 1' = c(1,12,0,1), check.names = FALSE)
rownames(mydata) <- c('Term A','Term B','Term C','Term D')
ui <- fluidPage(
useShinyjs(),
br(),
uiOutput("choices"),
rHandsontableOutput('hottable')
)
server <- function(input, output) {
uiTable <- reactiveVal(mydata)
observeEvent(input$hottable, {uiTable(hot_to_r(input$hottable))})
output$hottable <- renderRHandsontable({
rhandsontable(uiTable(),rowHeaderWidth = 100, useTypes = TRUE)%>%
hot_context_menu(allowRowEdit = FALSE, allowColEdit = FALSE) %>%
hot_cols(
colWidths = 80,
renderer = "function(instance, td, row, col, prop, value, cellProperties) {
Handsontable.renderers.NumericRenderer.apply(this, arguments);
if(instance.params && 1 === row) {td.style.background = '#eff0f1'} // shade row 2 only
}"
) %>%
hot_row(c(2), readOnly = TRUE) # makes row 2 non-editable
})
output$choices <-
renderUI(
selectInput(
"choices",
label = "User selects value to reflect in row 2 of table below:",
choices = c(1,2,3)
)
)
}
shinyApp(ui,server)
We can add another observeEvent to modify the reactiveVal uiTable:
library(rhandsontable)
library(shiny)
library(shinyjs)
mydata <- data.frame('Series 1' = c(1,1,0,1), check.names = FALSE)
rownames(mydata) <- c('Term A','Term B','Term C','Term D')
ui <- fluidPage(
useShinyjs(),
br(),
uiOutput("choices"),
rHandsontableOutput('hottable')
)
server <- function(input, output) {
uiTable <- reactiveVal(mydata)
observeEvent(input$hottable, {uiTable(hot_to_r(input$hottable))})
output$hottable <- renderRHandsontable({
rhandsontable(uiTable(),rowHeaderWidth = 100, useTypes = TRUE)%>%
hot_context_menu(allowRowEdit = FALSE, allowColEdit = FALSE) %>%
hot_cols(
colWidths = 80,
renderer = "function(instance, td, row, col, prop, value, cellProperties) {
Handsontable.renderers.NumericRenderer.apply(this, arguments);
if(instance.params && 1 === row) {td.style.background = '#eff0f1'} // shade row 2 only
}"
) %>%
hot_row(c(2), readOnly = TRUE) # makes row 2 non-editable
})
output$choices <-
renderUI({
selectInput(
"choices",
label = "User selects value to reflect in row 2 of table below:",
choices = c(1,2,3)
)
})
observeEvent(input$choices, {
tmpTable <- uiTable()
tmpTable$`Series 1`[2L] <- as.numeric(input$choices)
uiTable(tmpTable)
})
}
shinyApp(ui,server)
PS: are you aware of the fact, that you can embed dropdowns directly in rhandsontable? Please check this answer.
I have the following shiny app where the user can change the values of a table, however, if the user leaves an empty date field it generates an error but I don't know how to solve it.
I have tried to put the new value as as.character, as.Date, as.Posixct but it has not worked, I would appreciate any kind of guidance or help.
This is the message that the console throws:
Warning: Error in charToDate: character string is not in a standard unambiguous format
[No stack trace available]
Thank you
library(shiny)
#library(shinyjs)
library(DT)
#library(data.table)
#library(shinyalert)
#library(openxlsx)
#library(shinyFiles)
#library(dplyr)
#library(stringi)
#useShinyalert()
df <- data.frame(
Var1 = letters[1:10],
Var2 = round(rnorm(10),3),
Date1 = seq(as.Date("2000/01/01"), by = "month", length.out = 10),
Date2 = seq(as.Date("2000/01/01"), by = "month", length.out = 10)
)
d1 <- reactiveValues()
d1$Data <- df
server <- function(input, output, session){
# RENDER TABLE ----
data.tabla <- reactive({
df <- d1$Data
return(df)
})
output$df_data <- renderDataTable({
df <- datatable(
data.tabla(),
selection = 'single', editable = TRUE, rownames = FALSE,
options = list(
paging = TRUE,
# scrollX = TRUE,
searching = TRUE,
fixedColumns = TRUE,
autoWidth = TRUE,
ordering= FALSE,
dom = 'Bfrtip',
buttons = c('excel')
),
class = "display"
)
return(df)
})
observeEvent(input$df_data_cell_edit, {
d1$Data[input$df_data_cell_edit$row,
input$df_data_cell_edit$col+1] <<- input$df_data_cell_edit$value
})
}
# UI ----
ui <- fluidPage(
sidebarPanel(),
mainPanel(
DT::dataTableOutput("df_data"))
)
shinyApp(ui, server)
You should not use the global assignment operator <<- along with reactiveValues. Please try the following:
library(shiny)
library(DT)
DF <- data.frame(
Var1 = letters[1:10],
Var2 = round(rnorm(10), 3),
Date1 = seq(as.Date("2000/01/01"), by = "month", length.out = 10),
Date2 = seq(as.Date("2000/01/01"), by = "month", length.out = 10)
)
d1 <- reactiveValues(Data = DF)
server <- function(input, output, session) {
DT <- reactive({
d1$Data
})
output$df_data <- renderDataTable({
datatable(
DT(),
selection = 'single',
editable = TRUE,
rownames = FALSE,
options = list(
paging = TRUE,
# scrollX = TRUE,
searching = TRUE,
fixedColumns = TRUE,
autoWidth = TRUE,
ordering = FALSE,
dom = 'Bfrtip',
buttons = c('excel')
),
class = "display"
)
})
observeEvent(input$df_data_cell_edit, {
d1$Data[input$df_data_cell_edit$row, input$df_data_cell_edit$col + 1] <- input$df_data_cell_edit$value
})
}
ui <- fluidPage(sidebarPanel(), mainPanel(DT::dataTableOutput("df_data")))
shinyApp(ui, server)
You could check that the Date columns are in proper Date format:
library(shiny)
df <- data.frame(
Var1 = letters[1:10],
Var2 = round(rnorm(10),3),
Date1 = seq(as.Date("2000/01/01"), by = "month", length.out = 10),
Date2 = seq(as.Date("2000/01/01"), by = "month", length.out = 10)
)
d1 <- reactiveValues()
d1$Data <- df
server <- function(input, output, session){
# RENDER TABLE ----
data.tabla <- reactive({
df <- d1$Data
return(df)
})
output$df_data <- renderDataTable({
df <- datatable(
data.tabla(),
selection = 'single', editable = TRUE, rownames = FALSE,
options = list(
paging = TRUE,
# scrollX = TRUE,
searching = TRUE,
fixedColumns = TRUE,
autoWidth = TRUE,
ordering= FALSE,
dom = 'Bfrtip',
buttons = c('excel')
),
class = "display"
)
return(df)
})
observeEvent(input$df_data_cell_edit, {
value <- input$df_data_cell_edit$value
row <- input$df_data_cell_edit$row
col <- input$df_data_cell_edit$col + 1
if (col >= 3 & tryCatch({
as.Date(value); TRUE},error = function(err) {FALSE}) ) {
d1$Data[row,col] <<- input$df_data_cell_edit$value
} else {
showModal(modalDialog(
title = "Wrong date format",
"Check date format!"
))
d1$Data[row,col] <- NA
}
})
}
# UI ----
ui <- fluidPage(
sidebarPanel(),
mainPanel(
DT::dataTableOutput("df_data"))
)
shinyApp(ui, server)
I have created the following shiny App
library(shiny)
library(rhandsontable)
ui <- fluidPage(
sidebarLayout(sidebarPanel = "Inputparameter",
selectInput(inputId = "Name", label = "Name", choices = c("A", "B", "C"))),
mainPanel (rHandsontableOutput(outputId = 'Adjusttable', width ='100%', height = 100%')))
server <- function(input, output, session) {
output$Adjusttable<-renderRHandsontable({
DF = data.frame(ID = 1:7,'Column2' = 0, Start = "D",FM="",stringsAsFactors = FALSE)
names(DF)[names(DF)=='Column2']<- input$Name
names(DF)[names(DF)=='FM']<-'FM'
DF$ID<-NULL
rhandsontable(DF, width = 280, height = 677,stretchH = "all") %>%
hot_col(col = "Start", type = "dropdown", source = c("Fw", "Sw"), fillHandle =
list(direction='vertical', autoInsertRow=TRUE))%>%
hot_context_menu(allowRowEdit = TRUE, allowColEdit = FALSE)
}, quoted = FALSE )}
shinyApp(ui, server)
The following results in an app with an editable table. When we fill values in the table,, and change the item in the name drop down, the values get reset to 0 and the table defaults to its default state. Is there a way to fill the table, change the number of rows, etc , change the name input and avoid resetting the table. I request someone to take a look.
Try this
library(shiny)
library(rhandsontable)
library(DT)
DF <- data.frame(ID = 1:7,Column2 = 0, Start = "D",FM="",stringsAsFactors = FALSE)
names(DF)[names(DF)=='FM']<-'FM'
DF$ID<-NULL
ui <- fluidPage(
sidebarLayout(
sidebarPanel( "Inputparameter",
selectInput(inputId = "Name", label = "Name", choices = c("A", "B", "C"))),
mainPanel( rHandsontableOutput(outputId = 'hot', width ='100%', height = '100%')
, DTOutput("t1")
)
)
)
server <- function(input, output, session) {
DF1 <- reactiveValues(data=DF)
observe({
input$Name
names(DF1$data)[1] <- input$Name
})
output$hot<-renderRHandsontable({
rhandsontable(DF1$data, width = 280, height = 677,stretchH = "all") %>%
hot_col(col = "Start", type = "dropdown", source = c("Fw", "Sw"), fillHandle =
list(direction='vertical', autoInsertRow=TRUE)) %>%
hot_context_menu(allowRowEdit = TRUE, allowColEdit = FALSE)
}, quoted = FALSE )
observe({
if (!is.null(input$hot)){
DF1$data <- (hot_to_r(input$hot))
}
})
output$t1 <- renderDT(DF1$data)
}
shinyApp(ui, server)
Hi would like to have a dynamic(changing number of rows) rhandsontable using the input from radio buttons.
So I've been working on a shiny that needs data input into a table. However when adding more complexity an annual option was needed. So with the current table I could ask the user to fill in only the first row but that is just not pretty.
This is a reproducible example of the table as it currently stands
library(shiny)
library(rhandsontable)
ui <- fluidPage(
br(),
rHandsontableOutput('table'),
textOutput('result'),
br(),
actionButton("recalc", "re-enter data")
)
rowNames <- c("Spring", "Summer", "Autum", "Winter", "Sum")
defaultDF <- data.frame(
row.names = rowNames,
Lake = rep(NA_integer_, 5),
Beach = rep(NA_integer_, 5),
Garden = rep(NA_integer_, 5),
stringsAsFactors = FALSE
)
server <- function(input, output, session)
({
values <- reactiveValues(data = defaultDF) ## assign it with NULL
## button press resets now the data frame
observeEvent(input$recalc, {
values$data[] <- NA_integer_
})
observe({
req(input$table)
DF <- hot_to_r(input$table)
DF[setdiff(rowNames, "Sum"),]
DF["Sum",] <- colSums(DF[setdiff(rowNames, "Sum"),], na.rm = TRUE)
values$data <- DF
})
output$table <- renderRHandsontable({
req(values$data)
rhandsontable(values$data, rowHeaderWidth = 100) %>%
hot_row(nrow(values$data), readOnly = TRUE)
})
})
shinyApp(ui = ui, server = server)
What I'm attempting to do (in the code below) is to use the value in the radio buttons to change the number of rows in the table. Unfortunatly it has not worked. Any pointer would be very much appreciated.
library(shiny)
library(rhandsontable)
ui <- fluidPage(
br(),
rHandsontableOutput('table'),
textOutput('result'),
br(),
actionButton("recalc", "re-enter data")
radioButtons("Step", label = h4("Choose Step"),
choices = list("Annual" = 2, "Season" = 5),
inline= TRUE, selected = 1),
)
server <- function(input, output) ({
tabval<- reactive({
SeasonAnunal<- rowNames <- if (input$Step==2){ rowNames <- c("Spring", "Summer", "Autum", "Winter", "Sum")
} else{
rowNames <-c("Annual","Sum")}
defaultDF <- data.frame(
row.names = rowNames,
Lake = rep(NA_integer_, tabval()),
Beach = rep(NA_integer_, tabval()),
Garden = rep(NA_integer_, tabval()),
stringsAsFactors = FALSE)
})
values <- reactiveValues(data = defaultDF) ## assign it with NULL
## button press resets now the data frame
observeEvent(input$recalc, {
values$data[] <- NA_integer_
})
observe({
req(input$table)
DF <- hot_to_r(input$table)
DF[setdiff(rowNames, "Sum"),]
DF["Sum",] <- colSums(DF[setdiff(rowNames, "Sum"),], na.rm = TRUE)
values$data <- DF
})
output$table <- renderRHandsontable({
req(values$data)
rhandsontable(values$data, rowHeaderWidth = 100) %>%
hot_row(nrow(values$data), readOnly = TRUE)
})
})
shinyApp(ui = ui, server = server)
I'm not sure how your annual table should look like, but please check the following:
library(shiny)
library(rhandsontable)
ui <- fluidPage(
br(),
rHandsontableOutput('table'),
textOutput('result'),
br(),
actionButton("recalc", "re-enter data"),
radioButtons("Step", label = h4("Choose Step"),
choices = list("Annual" = 2, "Season" = 5),
inline= TRUE, selected = 2)
)
rowNames <- list("5" = c("Spring", "Summer", "Autum", "Winter", "Sum"), "2" = c("Year", "Sum"))
server <- function(input, output, session)
({
values <- reactiveValues(data = NULL) ## assign it with NULL
observeEvent(input$Step, {
req(input$Step)
values$data <- data.frame(
row.names = rowNames[[input$Step]],
Lake = rep(NA_integer_, as.integer(input$Step)),
Beach = rep(NA_integer_, as.integer(input$Step)),
Garden = rep(NA_integer_, as.integer(input$Step)),
stringsAsFactors = FALSE
)
})
## button press resets now the data frame
observeEvent(input$recalc, {
values$data[] <- NA_integer_
})
observe({
req(input$table)
DF <- hot_to_r(input$table)
DF[setdiff(rownames(DF), "Sum"),]
DF["Sum",] <- colSums(DF[setdiff(rownames(DF), "Sum"),], na.rm = TRUE)
values$data <- DF
})
output$table <- renderRHandsontable({
req(values$data)
rhandsontable(values$data, rowHeaderWidth = 100) %>%
hot_row(nrow(values$data), readOnly = TRUE)
})
})
shinyApp(ui = ui, server = server)
I want to create a web app, which allows user to enter input in numericInput object, which is embedded in DataTable and recalculates result (multiplication of column with some static values and a user input column) in another column.
I believe that when I set a reactive function which wraps around merging dataset and user input column and later I call it from RenderDataTable, that I somehow break the reactivity and I don't have a clue how to keep reactivity within table dependent on user input (which is also in the table). Please help.
Reproducible example to where I am stuck:
library(shiny)
library(DT)
set.seed(21)
db <- data.frame(ent = rep(x = 1,5),
group = c("G","M","O","F","L"),
val = sample(1:100, 5, replace=TRUE))
ui <- fluidPage(
titlePanel(paste0("entity - ", unique(db$ent))),
sidebarLayout(
sidebarPanel(
helpText("Shiny app calculation")
),
mainPanel(
DT::dataTableOutput("table")
))
)
numericText <- function(FUN, id_nums, id_base, label, value, ...) {
inputs <- 1:length(id_nums)
for (i in 1:length(inputs)) {
inputs[i] <- as.character(FUN(paste0(id_base,
id_nums[i]), label, value, ...))
}
return(inputs)
}
inputs <- numericText(numericInput,
id_nums = as.character(1:5),
id_base = "input_",
label = NULL,
value = 0)
db <- data.frame(db,
num = inputs)
server <- function(input, output, session) {
shinyValue = function(id, len) {
unlist(lapply(seq_len(len), function(i) {
value = input[[paste0(id, i)]]
if (is.null(value)) NA else value
}))
}
output_table <- reactive({
data.frame(db, calc = shinyValue("input_", 5))
})
output$table <- renderDataTable({
datatable(output_table(), rownames = FALSE, escape = FALSE, selection
= 'none', options = list(paging = FALSE, ordering = FALSE, searching
= FALSE, preDrawCallback = JS('function() {
Shiny.unbindAll(this.api().table().node()); }'), drawCallback =
JS('function() { Shiny.bindAll(this.api().table().node()); } ')))
})
}
shinyApp(ui = ui, server = server)
Also maybe it helps - I was able to do this if I remove reactive expression from the dataframe and if I write result in another output type(however this is not a solution, since my main purpose is to write it in another column in DataTable):
library(shiny)
library(DT)
set.seed(21)
db <- data.frame(ent = rep(x = 1,5),
group = c("G","M","O","F","L"),
val = sample(1:100, 5, replace=TRUE))
ui <- fluidPage(
titlePanel(paste0("entity - ", unique(db$ent))),
sidebarLayout(
sidebarPanel(
helpText("Shiny app calculation")
),
mainPanel(
DT::dataTableOutput("table"),
verbatimTextOutput("text")
))
)
numericText <- function(FUN, id_nums, id_base, label, value, ...) {
inputs <- 1:length(id_nums)
for (i in 1:length(inputs)) {
inputs[i] <- as.character(FUN(paste0(id_base,
id_nums[i]), label, value, ...))
}
return(inputs)
}
inputs <- numericText(numericInput,
id_nums = as.character(1:5),
id_base = "input_",
label = NULL,
value = 0)
db <- data.frame(db,
num = inputs)
server <- function(input, output, session) {
shinyValue = function(id, len) {
unlist(lapply(seq_len(len), function(i) {
value = input[[paste0(id, i)]]
if (is.null(value)) NA else value
}))
}
output_table <- db
output$table <- renderDataTable({
datatable(output_table, rownames = FALSE, escape = FALSE, selection
= 'none', options = list(paging = FALSE, ordering = FALSE, searching
= FALSE, preDrawCallback = JS('function() {
Shiny.unbindAll(this.api().table().node()); }'), drawCallback =
JS('function() { Shiny.bindAll(this.api().table().node()); } ')))
})
}
output$text <- reactive({shinyValue("input_", 5) * db$val
})
shinyApp(ui = ui, server = server)
I couldn't fully understand your code so I've myself produced another reproducible example based on a bunch of other answers especially this one.
library(shiny)
library(data.table)
library(rhandsontable)
DF = data.frame(num = 1:10, qty = rep(0,10), total = 1:10,
stringsAsFactors = FALSE)
#DF = rbind(DF, c(0,0,0))
ui = fluidPage(
titlePanel("Reactive Table "),
fluidRow(box(rHandsontableOutput("table", height = 400)))
)
server = function(input, output) {
data <- reactiveValues(df=DF)
observe({
input$recalc
data$df <- as.data.frame(DF)
})
observe({
if(!is.null(input$table))
data$df <- hot_to_r(input$table)
})
output$table <- renderRHandsontable({
rhandsontable(data$df)
})
output$table <- renderRHandsontable({
data$df$total <- data$df$num * data$df$qty
print(sum(data$df$num*data$df$price) )
rhandsontable(data$df, selectCallback = TRUE)
})
}
shinyApp(ui, server)
The very first idea is to use rhandsontable which is specifically for this kind of purpose.