User-interactive table made from reactive data - r

I am very new to Shiny and struggle to understand reactivity.
Context : I want user to choose a name for a column, add this column to a reactive table and then edit this table. The table is reactive (it comes from an uploaded file filtered by user).
Thanks to this answer everything work fine with a non-reactive table (see mydata <- mtcars[1:5,]).
But it doesn't work when mydata becomes reactive!
Here is a reproductible working example with NON-REACTIVE data from #dww answer:
library(rhandsontable)
ui <- fluidPage(
h2("The mtcars data"),
rHandsontableOutput("mytable"),
textInput('NewCol', 'Enter new column name'),
radioButtons("type", "Column type:",
c("Integer" = "integer",
"Floating point" = "numeric",
"Text" = "character")),
actionButton("goButton", "Update Table")
)
server <- function(input, output) {
mydata <- mtcars[1:5,]
output$mytable = renderRHandsontable(df())
df <- eventReactive(input$goButton, {
if(input$NewCol!="" && !is.null(input$NewCol) && input$goButton>0){
if (input$type == "integer") v1 <- integer(NROW(mydata))
if (input$type == "numeric") v1 <- numeric(NROW(mydata))
if (input$type == "character") v1 <- character(NROW(mydata))
newcol <- data.frame(v1)
names(newcol) <- input$NewCol
mydata <<- cbind(mydata, newcol)
}
rhandsontable(mydata, stretchH = "all")
}, ignoreNULL = FALSE)
observe(if (!is.null(input$mytable)) mydata <<- hot_to_r(input$mytable))
}
shinyApp(ui,server)
I have unsuccessfully tried these changes inside the code (basically I have changed all mydata for mydata()):
server <- function(input, output) {
# mydata <- reactive({ }) #make mydata a reactive object
output$mytable = renderRHandsontable(df())
df <- eventReactive(input$goButton, {
if(input$NewCol!="" && !is.null(input$NewCol) && input$goButton>0){
if (input$type == "integer") v1 <- integer(NROW(mydata()))
if (input$type == "numeric") v1 <- numeric(NROW(mydata()))
if (input$type == "character") v1 <- character(NROW(mydata()))
newcol <- data.frame(v1)
names(newcol) <- input$NewCol
mydata <<- cbind(mydata(), newcol)
}
rhandsontable(mydata(), stretchH = "all")
}, ignoreNULL = FALSE)
observe(if (!is.null(input$mytable)) mydata() <<- hot_to_r(input$mytable))}
I did not find this question answers/comments useful to answer my problem).
Could you explain how to use a reactive mydata inside #dww awesome answer?
[EDIT : title updated to better fit the answer]

I trimmed some extra features, like column data types... As a general rule - anything which you'd be rendering, can become reactive just by wrapping it in "reactive". Below I use "reactiveValues" but other reactive methods would work too.
A generalised way of making your output reactive to changes in the data's input -
foo_func = function() return(mydata)
foo_func_reactive = reactive(foo_func)
output$foo = renderMethod( foo_func_reactive() )
For your example:
shinyApp(
ui = fluidPage(
rHandsontableOutput("out_tbl"),
textInput(inputId = "in_txt", label = "New column name"),
actionButton(inputId = "in_btn1", label = "Add new column to the table above ..."),
actionButton(inputId = "in_btn2", label = "... Or, generate new data")
),
server = function(input, output, session) {
# establishes tbl_react as the holder for our reactive data, and pre-fills it for the first display with 1,2,3
tbl_react <- reactiveValues(tbl =
data.frame(a = c(1,2,3))
)
# button one adds a new column with the inputted name
observeEvent(input$in_btn1,{
newcolname <- as.character(input$in_txt)
newcol <- character(NROW(tbl_react$tbl))
tbl_react$tbl <- cbind(tbl_react$tbl, newcol)
colnames(tbl_react$tbl) <- c(colnames(tbl_react$tbl)[1:ncol(tbl_react$tbl)-1], newcolname)
})
# to show our output data is reactive, we can take a dependancy on button two to generate new data - this could instead be using an uploaded file
observeEvent(input$in_btn2,{
tbl_react$tbl <- data.frame(b = c(9,10,11))
})
output$out_tbl = renderRHandsontable( rhandsontable(tbl_react$tbl) )
}
)

Related

Errors in recoding variables in shiny apps

I'm trying to set codes to recode in shiny web application. However, it doesn't work for me.
Here's my code.
library(shiny)
library(rlang)
library(dplyr)
ui <- fluidPage(
titlePanel("Short Form Web App"),
sidebarPanel(
numericInput("num1","previous vector", value = NULL),
numericInput("num2","post vector", value = NULL),
selectInput("var","select Variable",names(mtcars)),
textInput("new_var","new variable names")
),
mainPanel(
verbatimTextOutput("tab1"),
verbatimTextOutput("tab2"),
actionButton("do","Do")
)
)
server <- function(input, output) {
output$tab1 <- renderPrint({
table(mtcars[["cyl"]])
})
rv <- reactiveValues(data = NULL)
rv$data <- mtcars
observeEvent(input$do,{
new_var <- input$new_var
new <- rv$data %>% transmute(!!new_var := case_when(input$var == input$num1 ~ input$num2))
rv$data <- bind_cols(rv$data,new)
output$tab2 <- renderPrint({
str(rv$data)
})
})
}
shinyApp(ui,server)
What I'm trying to do is recode previous vector to new vector like recode, but the result keeps showing NA..
Could anyone help me fix this problem?
I would very be very appreciated with your helps.
Thank you in advance.
Two issues:
As input$var is character you first have to convert to a symbol, i.e. use !!sym(input$var)
In your case_when you missed to set a default value. Hence, all values not specified to be recoded will be assigned NA.
Try this:
library(shiny)
library(rlang)
library(dplyr)
ui <- fluidPage(
titlePanel("Short Form Web App"),
sidebarPanel(
numericInput("num1","previous vector", value = NULL),
numericInput("num2","post vector", value = NULL),
selectInput("var","select Variable",names(mtcars)),
textInput("new_var","new variable names")
),
mainPanel(
verbatimTextOutput("tab1"),
verbatimTextOutput("tab2"),
actionButton("do","Do")
)
)
server <- function(input, output) {
output$tab1 <- renderPrint({
table(mtcars[["cyl"]])
})
rv <- reactiveValues(data = NULL)
rv$data <- mtcars
observeEvent(input$do,{
new_var <- input$new_var
new <- rv$data %>% transmute(!!sym(new_var) := case_when(
!!sym(input$var) == input$num1 ~ as.double(input$num2),
TRUE ~ !!sym(input$var)))
rv$data <- bind_cols(rv$data,new)
output$tab2 <- renderPrint({
str(rv$data)
})
})
}

R shiny puzzling warning: Input to asJSON(keep_vec_names=TRUE) is a named vector

I have written a shiny app that permits the user to amend individual rows of a dataframe but when I try to include an option to append new rows I get this warning on the console:
Input to asJSON(keep_vec_names=TRUE) is a named vector. In a future version of jsonlite, this option will not be supported, and named vectors will be translated into arrays instead of objects. If you want JSON object output, please use a named list instead. See ?toJSON.
and in a text input box that should contain an item from one column of the data frame the following appears instead:
[object Object]
There are a few answers here that refer to the warning message but in different conditions than apply in my case, and they appear to have little in common with each other apart from the warning message.
Here is my app for amending the dataframe. It works perfectly.
require(shiny)
in.df <- data.frame(name = c("Alice","Bob","Charles"),
age = c(22, 25, 36))
rownames(in.df) <- NULL
runApp(
list(
ui = fluidPage(
sidebarPanel(
numericInput("line", "Line number", value = 1),
textInput("name", "Name:"),
numericInput("age", "Age:", value = 25),
actionButton("amendButton", "Amend an entry")
),
mainPanel(
tableOutput("table"))
),
server = function(input, output, session){
values <- reactiveValues()
values$df <- in.df
current_line <- reactive({
il <- input$line
nr <- nrow(values$df)
if(il > nr){
return(nr)
} else if(il <= 0){
return(1)
} else{
return(il)
}
})
amendData <- observe({
if(input$amendButton > 0){
newLine <- isolate(c(input$name, input$age))
values$df <- isolate(values$df[- current_line(), ])
isolate(values$df <- rbind(as.matrix(values$df), unlist(newLine)))
values$df <- values$df[order(values$df[,1]),]
}
})
observe({
updateTextInput(session = session,
inputId = 'name',
value = values$df[unlist( current_line()),1]
)
updateNumericInput(session = session,
inputId = 'age',
value = values$df[unlist( current_line()),2]
)
updateNumericInput(session = session ,
inputId = 'line',
value = current_line()
)
})
output$table <- renderTable(values$df )
}
)
)
It seemed to me that it would be a simple matter to add an 'append' option in the following way:
Add a new action button
actionButton("appendButton", "Append an entry")
Include a corresponding handler that can be very similar indeed to the handler for the addButton:
addData <- observe({
if(input$appendButton > 0){
newLine <- isolate(c(input$name, input$age))
isolate(values$df <- rbind(as.matrix(values$df), unlist(newLine)))
values$df <- values$df[order(values$df[,1]),]
}
})
The only difference of substance between the two handlers is that the new one does not need the line
values$df <- isolate(values$df[- current_line(), ])
because in the append case no old row is being removed.
But it does not work: I get the warning and the odd change to the text input box that I described.
In shiny 1.6 I got a running app after I changed amendData <- observe to amendData <- observeEvent. Otherwise the code got stuck in an infinite loop.
However, in order to be able to add new rows I had to change reactive value current_line. The code always resets it to an existing row so that one can never add new entries.
I had changed current_line so that it also allowed it to be nrow + 1 and cleared the numeric input fields when current_line was larger than the number of rows.
Now, I finally saw the situation that was described in the question.
It was caused by values$df <- rbind(as.matrix(values$df), unlist(newLine)). R added the new row with a name. The named rows of the data frame seemed to be the problem when sent to the UI. My guess is that this is a problem deeply buried in the reactive messaging system of Shiny.
require(shiny)
in.df <- data.frame(name = c("Alice","Bob","Charles"),
age = c(22L, 25L, 36L))
rownames(in.df) <- NULL
runApp(
list(
ui = fluidPage(
sidebarPanel(
numericInput("line", "Line number", value = 1),
textInput("name", "Name:"),
numericInput("age", "Age:", value = 25),
actionButton("amendButton", "Amend an entry")
),
mainPanel(
tableOutput("table"))
),
server = function(input, output, session){
values <- reactiveValues()
values$df <- in.df
current_line <- reactive({
il <- req(input$line)
nr <- nrow(values$df)
if(il > nr){
return(nr+1)
} else if (il <= 0){
return(1)
} else {
return(il)
}
})
amendData <- observeEvent(input$amendButton, {
isolate({
newLine <- c(input$name, as.numeric(input$age))
values$df <- values$df[- current_line(), ]
values$df <- rbind(values$df, unname(newLine))
})
values$df <- values$df[order(values$df[,1]),]
})
observe({
updateNumericInput(session = session, inputId = 'line',
value = current_line())
if (current_line() <= nrow(values$df)) {
updateNumericInput(session = session, inputId = 'age',
value = values$df[current_line(), 2])
updateTextInput(session = session, inputId = 'name',
value = values$df[current_line(), 1])
}
else {
updateNumericInput(session = session, inputId = 'age', value = "")
updateNumericInput(session = session, inputId = 'name', value = "")
}
})
output$table <- renderTable( values$df )
}
)
)

Button to add entry column to r shiny datatable

I am looking to find a way to add a button to a datatable in r shiny that:
Adds an empty column to the data table each time it is clicked (and dataframe that made the table in the first place
Which the user can fill himself
With numeric or text values
And set their own column name to describe the type of entry values.
To for instance add lab note records to instrument data that is already in the shiny app manually
I am asking in case a more skilled person who has a better clue than me knows how to do this.
I have read a bunch of pages, but at best the example I found provides 1 fixed empty column with a fixed name
empty column
A dummy table from the package :
library(DT)
ui <- basicPage(
h2("The mtcars data"),
DT::dataTableOutput("mytable")
)
server <- function(input, output) {
output$mytable = DT::renderDataTable({
mtcars
})
}
shinyApp(ui, server)
You can use a button to add a new column to a R shiny datatable like this:
ui <- fluidPage(
h2("The mtcars data"),
DT::dataTableOutput("mytable"),
textInput('NewCol', 'Enter new column name'),
radioButtons("type", "Column type:",
c("Integer" = "integer",
"Floating point" = "numeric",
"Text" = "character")),
actionButton("goButton", "Update Table")
)
server <- function(input, output) {
mydata <- mtcars
output$mytable = DT::renderDataTable(df())
df <- eventReactive(input$goButton, {
if(input$NewCol!="" && !is.null(input$NewCol) && input$goButton>0){
if (input$type == "integer") v1 <- integer(NROW(mydata))
if (input$type == "numeric") v1 <- numeric(NROW(mydata))
if (input$type == "character") v1 <- character(NROW(mydata))
newcol <- data.frame(v1)
names(newcol) <- input$NewCol
mydata <<- cbind(mydata, newcol)
}
mydata
}, ignoreNULL = FALSE)
}
shinyApp(ui,server)
If you also need to edit the contents of the cells interactively, you can use renderRHandsontable instead of renderDataTable. Like this:
library(rhandsontable)
ui <- fluidPage(
h2("The mtcars data"),
rHandsontableOutput("mytable"),
textInput('NewCol', 'Enter new column name'),
radioButtons("type", "Column type:",
c("Integer" = "integer",
"Floating point" = "numeric",
"Text" = "character")),
actionButton("goButton", "Update Table")
)
server <- function(input, output) {
mydata <- mtcars[1:5,]
output$mytable = renderRHandsontable(df())
df <- eventReactive(input$goButton, {
if(input$NewCol!="" && !is.null(input$NewCol) && input$goButton>0){
if (input$type == "integer") v1 <- integer(NROW(mydata))
if (input$type == "numeric") v1 <- numeric(NROW(mydata))
if (input$type == "character") v1 <- character(NROW(mydata))
newcol <- data.frame(v1)
names(newcol) <- input$NewCol
mydata <<- cbind(mydata, newcol)
}
rhandsontable(mydata, stretchH = "all")
}, ignoreNULL = FALSE)
observe(if (!is.null(input$mytable)) mydata <<- hot_to_r(input$mytable))
}
shinyApp(ui,server)

R - Disabled action button conditional to column's name

Below a simplified version of my shiny app. I looked through some of the examples in the shinyjs package and I did not find anything that could help me.
I want to disable the Submit button if one of the data frame uploaded (in my real example) or selected has a specific column name (Col 3 in the example below).
Can this be done with shinyjs?
library(rhandsontable)
library(shiny)
library(shinyjs)
df1 <- data.frame(col1 = rnorm(20),
col2 = rep(T, 20))
df2 <- data.frame(col1 = rnorm(20),
col2 = rep(F, 20),
col3 = rnorm(20))
server <- function(input, output) {
values = reactiveValues()
values[["df1"]] <- df1
values[["df2"]] <- df2
df <- reactive({
if (input$df == "df1") {
df <- values[["df1"]]
} else {
df <- values[["df2"]]
}
df
})
observeEvent(input$Submit, {
shinyjs::alert("Thank you!")
})
#observe({
# if (is.null(input$df) || input$df == "df1") {
# shinyjs::disable("submit")
#} else {
# shinyjs::enable("submit")
#}
#})
output$out <- renderRHandsontable({
hot <- rhandsontable(df())
hot
})
}
ui <- fluidPage(
shinyjs::useShinyjs(),
sidebarLayout(sidebarPanel(
selectInput(
'df', 'Select data.frame:',
choices = c('df1', 'df2'),
selected = 'df1'
),
actionButton("Submit", label = "Submit")
),
mainPanel(rHandsontableOutput("out"))))
shinyApp(ui = ui, server = server)
First, there is a small typo: Notice the capital "S".
shinyjs::disable("Submit")
Edit: To check for "col3" take the following code:
observe({
if (is.null(input$df) || sum(colnames(df()) == "col3")) {
shinyjs::disable("Submit")
}else{
shinyjs::enable("Submit")
}
})
Same for enable of course.

Get selected rows of Rhandsontable

I am using rhandsontable in a Shiny App and I would like to know how to use the getSelected() method of Handsontable in this case, as I intend to apply changes on the data.frame.
thank you!
You can obtain the selected row, column, range, and cell values, as well as the edited cells using selectCallback=TRUE. You can edit a cell by double-clicking on it, and accept the changes by pressing "return" or "enter".
Minimal example:
library(shiny)
library(rhandsontable)
ui=fluidPage(
rHandsontableOutput('table'),
verbatimTextOutput('selected')
)
server=function(input,output,session)({
df=data.frame(N=c(1:10),L=LETTERS[1:10],M=LETTERS[11:20])
output$table=renderRHandsontable(
rhandsontable(df,selectCallback = TRUE,readOnly = FALSE)
)
output$selected=renderPrint({
cat('Selected Row:',input$table_select$select$r)
cat('\nSelected Column:',input$table_select$select$c)
cat('\nSelected Cell Value:',
input$table_select$data[[
input$table_select$select$r]][[input$table_select$select$c]])
cat('\nSelected Range: R',input$table_select$select$r,
'C',input$table_select$select$c,':R',input$table_select$select$r2,
'C',input$table_select$select$c2,sep="")
cat('\nChanged Cell Row Column:',input$table$changes$changes[[1]][[1]],
input$table$changes$changes[[1]][[2]])
cat('\nChanged Cell Old Value:',input$table$changes$changes[[1]][[3]])
cat('\nChanged Cell New Value:',input$table$changes$changes[[1]][[4]])
})
}) # end server
shinyApp(ui = ui, server = server)
While rhandsontable is a real good implementation of handsontable (credit goes to #jrowen), currently it does not include getSelected().
The event of a user altering any cell (including selecting / deselecting a checkbox) is tracked by shiny. This gives the opportunity to use checkboxes to let the user to select (or de-select) one or more rows.
Unfortunately the logic to understand what has been selected needs to be developed on the server side by your code.
The snippet of code below may give you some idea on how to manage it.
options(warn=-1)
library(rhandsontable)
library(shiny)
options(warn=-1)
quantity <- id <- 1:20
label <- paste0("lab","-",quantity)
pick <- FALSE
iris_ <- data.frame(id=id,pick=pick, quantity=quantity,label=label,iris[1:20,] ,stringsAsFactors = FALSE)
mtcars_ <- data.frame(id=id,pick=pick, quantity=quantity,label=label,mtcars[1:20,] ,stringsAsFactors = FALSE)
iris_$Species <- NULL # i.e. no factors
#---------------------------
ui <- fluidPage(
fluidRow(
column(6,rHandsontableOutput('demTb')),
column(3,uiOutput("demSli")),
column(3, radioButtons("inButtn", label=NULL, choices= c("iris","mtcars"), selected = "iris", inline = TRUE))
)
)
server <- function(session, input, output) {
selData <- ""
output$demSli <- renderUI({
if(is.null(input$demTb) ) return()
isolate({
df_ <- hot_to_r(input$demTb)
index <- which(df_$pick==T)
if(length(index)==0) return()
labs <- iris_$label[index]
pages <- "test"
iter <- length(labs)
buttn <- 1
valLabs <- sapply(1:iter, function(i) {
if(is.null(input[[paste0(pages,"d",labs[i],buttn)]] )) {
0
} else { as.numeric(input[[paste0(pages,"d",labs[i],buttn)]]) }
})
#
toRender <- lapply(1:iter, function(i) {
sliderInput(inputId = paste0(pages,"d",labs[i],buttn),
label = h6(paste0(labs[i],"")),
min = -100,
max = 100,
step = 1,
value = valLabs[i],
post="%",
ticks = FALSE, animate = FALSE)
})
})
return(toRender)
})
#--------------------
rds <- reactive({
# if( is.null(input$demTb) ) {
if( input$inButtn == "iris") {
if(selData == "" | selData == "mtcars") {
selData <<- "iris"
return(iris_) # first time for iris
}
} else {
if(selData == "iris" ) {
selData <<- "mtcars"
return(mtcars_) # first time for mtcars
}
}
df_ <- hot_to_r(input$demTb)
isolate({
index <- which(df_$pick==T)
if(length(index)==0) return(df_)
labs <- iris_$label[index]
pages <- "test"
iter <- length(labs)
buttn <- 1
}) # end isolate
valLabs <- sapply(1:iter, function(i) {
if(is.null(input[[paste0(pages,"d",labs[i],buttn)]] )) {
0
} else {
as.numeric(input[[paste0(pages,"d",labs[i],buttn)]])/100
}
})
dft_ <- data.frame(label=labs, multi=valLabs, stringsAsFactors = FALSE)
dft_ <- merge(iris_,dft_,by="label", all.x=T)
dft_$quantity <- sapply(1:length(dft_$quantity), function(z) {
if( is.na( dft_$multi[z]) ) {
dft_$quantity[z]
} else { iris_$quantity[z]*(1 + dft_$multi[z]) }
})
dft_[with(dft_,order(as.numeric(id))),]
df_[with(df_,order(as.numeric(id))),]
df_$quantity <- df_$quantity
return(df_)
})
output$demTb <- renderRHandsontable({
if(is.null(rds() )) return()
df_ <- rds()
df_ <- df_[with(df_,order(as.numeric(id))),]
rhandsontable(df_, readOnly = FALSE, rowHeaders= NULL, useTypes= TRUE) %>%
hot_table(highlightCol = TRUE, highlightRow = TRUE)
})
}
shinyApp(ui, server)

Resources