Related
I've been trying to apply the solution in post Shiny App: How to get total sum by column to my situation but am unable to get it to work. I simply want the "Total" row at the bottom of the table to recalculate every time the user changes one of the fields above it, but I get an error message when un-commenting the observe() that is commented-out in the below code. This observe() is my attempt to implement the solution offered in the aforementioned post. What am I doing wrong here, and more generally what is the proper method of summing a column in rhandsontable?
Code:
library(rhandsontable)
library(shiny)
rowNames <- c('Hello A','Hello B','Hello C','Hello D','Total')
data <- data.frame(row.names = rowNames,'Col 1' = c(10,20,-5,18,43),check.names = FALSE)
ui <- fluidPage(br(),
rHandsontableOutput('hottable'),br(),
actionButton("addCol", "Add column"),br(),br(),
uiOutput("delCol_step1")
)
server <- function(input, output) {
uiTable <- reactiveVal(data)
observeEvent(input$hottable,{uiTable(hot_to_r(input$hottable))})
output$hottable <- renderRHandsontable({
rhandsontable(uiTable(),rowHeaderWidth = 100, useTypes = TRUE)
})
# observe({
# req(input$hottable)
# DF <- hot_to_r(input$hottable)
# DF[setdiff(rowNames, "Total"),]
# DF["Total",] <- colSums(DF[setdiff(rowNames, "Total"),], na.rm = TRUE)
# uiTable(DF)
# })
observeEvent(input$addCol, {
newCol2 <- data.frame(c(10,20,-5,18,43))
names(newCol2) <- paste("Col", ncol(hot_to_r(input$hottable)) + 1)
uiTable(cbind(uiTable(), newCol2))
})
output$delCol_step1 <-
renderUI(
selectInput(
"delCol_step2",
label = "Select column to delete:",
choices = colnames(hot_to_r(input$hottable)),
selected = "",
multiple = TRUE
)
)
observeEvent(input$delCol_step2,{
tmp <- uiTable()
if(ncol(tmp) > 1){
delCol <- input$delCol_step2
tmp <-tmp[,!(names(tmp) %in% delCol),drop=FALSE]
newNames <- sprintf("Col %d",seq(1:ncol(tmp)))
names(tmp) <- newNames
uiTable(tmp)
}
})
}
shinyApp(ui,server)
Unfortunately #MichaelDewar's answer is not correct.
colSums can handle single column data.frames just fine:
colSums(data.frame(1:10))
However, when indexing data.frames you have to make sure to avoid dimensions being dropped - as colSums does not work on vectors. Just use drop = FALSE to achive this:
library(rhandsontable)
library(shiny)
rowNames <- c('Hello A','Hello B','Hello C','Hello D','Total')
data <- data.frame(row.names = rowNames,'Col 1' = c(10,20,-5,18,43),check.names = FALSE)
ui <- fluidPage(br(),
rHandsontableOutput('hottable'),br(),
actionButton("addCol", "Add column"),br(),br(),
uiOutput("delCol_step1")
)
server <- function(input, output) {
uiTable <- reactiveVal(data)
observeEvent(input$hottable,{uiTable(hot_to_r(input$hottable))})
output$hottable <- renderRHandsontable({
rhandsontable(uiTable(),rowHeaderWidth = 100, useTypes = TRUE)
})
observe({
req(input$hottable)
DF <- hot_to_r(input$hottable)
DF[setdiff(rowNames, "Total"),]
DF["Total",] <- colSums(DF[setdiff(rowNames, "Total"),, drop = FALSE], na.rm = TRUE)
uiTable(DF)
})
observeEvent(input$addCol, {
newCol2 <- data.frame(c(10,20,-5,18,43))
names(newCol2) <- paste("Col", ncol(hot_to_r(input$hottable)) + 1)
uiTable(cbind(uiTable(), newCol2))
})
output$delCol_step1 <-
renderUI(
selectInput(
"delCol_step2",
label = "Select column to delete:",
choices = colnames(hot_to_r(input$hottable)),
selected = "",
multiple = TRUE
)
)
observeEvent(input$delCol_step2,{
tmp <- uiTable()
if(ncol(tmp) > 1){
delCol <- input$delCol_step2
tmp <-tmp[,!(names(tmp) %in% delCol),drop=FALSE]
newNames <- sprintf("Col %d",seq(1:ncol(tmp)))
names(tmp) <- newNames
uiTable(tmp)
}
})
}
shinyApp(ui,server)
Please see ?`[`, this related article or my earlier answer here.
The problem is that colSums doesn't work for a data frame with a single column. You have to use sum in that case. Put this in the server.
observe({
req(input$hottable)
DF <- hot_to_r(input$hottable)
if(ncol(DF)==1){
DF["Total",] <- sum(DF[setdiff(rowNames, "Total"),], na.rm = TRUE)
} else {
DF["Total",] <- colSums(DF[setdiff(rowNames, "Total"),], na.rm = TRUE)
}
uiTable(DF)
})
I am trying to use auto generated selectInput IDs inside the reactive element or observe event. When I explicitly write the input IDs like input$dfSelect1,input$dfSelect2,input$dfSelect3, it works as I wanted.
Since I don't know in advance how many IDs will be there (data will be user input), I need to create same input ID strings as automated, but it doesn't recognize it as a trigger in observe event or a input data in reactive element.
Here is the minimal reproducible example of my problem. if you comment out the line 1 req(input$dfSelect1,input$dfSelect2,input$dfSelect3) and line 2 dfx <- data.frame(carb = c(input$dfSelect1,input$dfSelect2,input$dfSelect3),stringsAsFactors = F) and remove the comment from the following lines, this will be the case I am trying to do.
any idea how to pass these values?
library(dplyr)
library(DT)
exdata <- head(mtcars, 3)
exdata$ROWs <- row.names(exdata)
ui <- fluidPage(
headerPanel("Example"),
mainPanel(
uiOutput("selectionUI"),
uiOutput("tableOutput")
)
)
server <- function(input, output, server) {
### reqString result <- input$dfSelect1,input$dfSelect2,input$dfSelect3
reqString <- noquote(paste0(unlist(lapply(1:length(sort(unique(row.names(exdata)))),function(i) {paste0("input$dfSelect",i,"")})),collapse = ","))
values <- reactiveValues(
upload_state = NULL
)
observe({
### 1-USE the line below with reqString instead -doesn't work ##
req(input$dfSelect1,input$dfSelect2,input$dfSelect3)
# req(reqString)
values$upload_state <- 'uploaded'
})
output$selectionUI <- renderUI({
df <- sort(unique(row.names(exdata)))
wellPanel(
lapply(1:length(df), function(i) {selectizeInput(paste0("dfSelect",i,""),df[i],choices=c("", unique(exdata$carb)))})
)
})
completeTable <- reactive({
browser()
if (is.null(values$upload_state)) {
return(exdata)
}else if (values$upload_state == 'uploaded') {
### 2-USE the line below with reqString instead -doesn't work##
dfx <- data.frame(carb = c(input$dfSelect1,input$dfSelect2,input$dfSelect3),stringsAsFactors = F)
# dfx <- data.frame(carb = c(reqString),stringsAsFactors = F)
dfx <- data.frame(carb =as.numeric(unlist(dfx)))
dataJoin <- exdata %>% left_join(dfx,by=("carb"))
}
})
output$tableOutput <- renderUI({
DT::dataTableOutput("dataTableServer")
})
output$dataTableServer <- DT::renderDataTable({
DT::datatable(completeTable())
})
}
shinyApp(ui = ui, server = server)
You can index input using [[ instead of $:
sapply(1:length(sort(unique(row.names(exdata)))),
FUN=function(x) req(input[[paste0("dfSelect", x)]]))
and
l <- sapply(1:length(sort(unique(row.names(exdata)))),
FUN=function(x) input[[paste0("dfSelect", x)]])
dfx <- data.frame(carb = l,stringsAsFactors = F)
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) )
}
)
I created a simple shiny app. The goal is to create a histogram with options to manipulate the plot for each dataset. The problem is that when I change a dataset application first show me empty plot and then present a correct plot. To understand the problem I add renderText which show me a number of rows in getDataParams dataset. It seems to me that isolate function should be a solution but I tried several configurations, apparently I still do not understand this function.
library(lazyeval)
library(dplyr)
library(shiny)
library(ggplot2)
data(iris)
data(diamonds)
ui <- fluidPage(
column(3,
selectInput("data", "", choices = c('', 'iris', 'diamonds')),
uiOutput('server_cols'),
uiOutput("server_cols_fact"),
uiOutput("server_params")
),
column(9,
plotOutput("plot"),
textOutput('text')
)
)
server <- function(input, output) {
data <- reactive({
switch(input$data, diamonds = diamonds, iris = iris)
})
output$server_cols <- renderUI({
validate(need(input$data != "", "Firstly select a dataset."))
data <- data()
nam <- colnames(data)
selectInput('cols', "Choose numeric columns:", choices = nam[sapply(data, function(x) is.numeric(x))])
})
output$server_cols_fact <- renderUI({
req(input$data)
data <- data(); nam <- colnames(data)
selectizeInput('cols_fact', "Choose a fill columns:",
choices = nam[sapply(data, function(x) is.factor(x))])
})
output$server_params <- renderUI({
req(input$cols_fact)
data <- isolate(data()); col_nam <- input$cols_fact
params_vec <- unique(as.character(data[[col_nam]]))
selectizeInput('params', "Choose arguments of fill columns:", choices = params_vec,
selected = params_vec, multiple = TRUE)
})
getDataParams <- reactive({
df <- isolate(data())
factor_col <- input$cols_fact
col_diverse <- eval(factor_col)
criteria <- interp(~col_diverse %in% input$params, col_diverse = as.name(col_diverse))
df <- df %>%
filter_(criteria) %>%
mutate_each_(funs(factor), factor_col)
})
output$text <- renderText({
if(!is.null(input$cols)) {
print(nrow(getDataParams()))
}
})
output$plot <- renderPlot({
if (!is.null(input$cols)) {
var <- eval(input$cols)
print('1')
diversifyData <- getDataParams()
factor_col <- input$cols_fact
print('2')
plot <- ggplot(diversifyData, aes_string(var, fill = diversifyData[[factor_col]])) +
geom_histogram(color = 'white', binwidth = 1)
print('3')
}
plot
})
}
shinyApp(ui, server)
Here is an answer that features quite minimal changes and gives probably some deeper insights into how to control reactivity in future projects.
Your program logic features some decisions of the kind "do A if B, but not if C". But it approaches them brutally, by repeating "do A if B" until finally "not C" is true. To be more precise: You want your getDataParams to be renewed (action A) if input$cols changes (action B), but it throws errors if input$params has not changed yet (condition C).
Okay, now to the fix: We use a feature of observeEvent to evaluate if getDataParams should be recalculated. Lets read (source):
Both observeEvent and eventReactive take an ignoreNULL parameter that
affects behavior when the eventExpr evaluates to NULL (or in the
special case of an actionButton, 0). In these cases, if ignoreNULL is
TRUE, then an observeEvent will not execute and an eventReactive will
raise a silent validation error.
So the change is basically one command. Change
getDataParams <- reactive({ ... })
to
getDataParams <- eventReactive({
if(is.null(input$params) || !(input$cols_fact %in% colnames(data()))){
NULL
}else{
if(all(input$params %in% data()[[input$cols_fact]])){
1
}else{
NULL
}
}, { ... }, ignoreNULL = TRUE)
Here we check if input$cols_fact is a valid column name and if input$params has already been assigned and if so, we check if input$params is a valid list of factors for the given column. This feature was mainly designed, I suppose, to check if some element exists (input$something returning NULL if it's not defined), but we abuse it for logic evaluation and return NULL in one case and 1 (or something not NULL) in the other.
In contrast to logical tests inside the reactive environment, getDataReactive won't be changed or won't trigger change events at all, if the condition is not met.
Note: This is the minimal solution I found. With this tool and/or other changes, the code can still be fairly improved.
Full Code below.
Greetings!
library(lazyeval)
library(dplyr)
library(shiny)
library(ggplot2)
data(iris)
data(diamonds)
ui <- fluidPage(
column(3,
selectInput("data", "", choices = c('', 'iris', 'diamonds')),
uiOutput('server_cols'),
uiOutput("server_cols_fact"),
uiOutput("server_params")
),
column(9,
plotOutput("plot"),
textOutput('text')
)
)
server <- function(input, output) {
data <- reactive({
switch(input$data, diamonds = diamonds, iris = iris)
})
output$server_cols <- renderUI({
validate(need(input$data != "", "Firstly select a dataset."))
data <- data()
nam <- colnames(data)
selectInput('cols', "Choose numeric columns:", choices = nam[sapply(data, function(x) is.numeric(x))])
})
output$server_cols_fact <- renderUI({
req(input$data)
data <- data(); nam <- colnames(data)
selectizeInput('cols_fact', "Choose a fill columns:",
choices = nam[sapply(data, function(x) is.factor(x))])
})
output$server_params <- renderUI({
req(input$cols_fact)
data <- isolate(data()); col_nam <- input$cols_fact
params_vec <- unique(as.character(data[[col_nam]]))
selectizeInput('params', "Choose arguments of fill columns:", choices = params_vec,
selected = params_vec, multiple = TRUE)
})
getDataParams <- eventReactive({
if(is.null(input$params) || !(input$cols_fact %in% colnames(data()))){
NULL
}else{
if(all(input$params %in% data()[[input$cols_fact]])){
1
}else{
NULL
}
}, {
df <- isolate(data())
factor_col <- input$cols_fact
col_diverse <- eval(factor_col)
criteria <- interp(~col_diverse %in% input$params, col_diverse = as.name(col_diverse))
df <- df %>%
filter_(criteria) %>%
mutate_each_(funs(factor), factor_col)
}, ignoreNULL = TRUE)
output$text <- renderText({
if(!is.null(input$cols)) {
print(nrow(getDataParams()))
}
})
output$plot <- renderPlot({
if (!is.null(input$cols)) {
var <- eval(input$cols)
print('1')
diversifyData <- getDataParams()
factor_col <- input$cols_fact
print('2')
plot <- ggplot(diversifyData, aes_string(var, fill = diversifyData[[factor_col]])) +
geom_histogram(color = 'white', binwidth = 1)
print('3')
}
plot
})
}
shinyApp(ui, server)
To best explaining the flow - I create a picture that explain how the plot get refresh as below:
So, with no isolate code, you will any change in any change on any control on the code will trigger the change to the control on the end of arrow. In this case which end up result the plot refresh 5 times.
With the isolate code in your code from above post, you already eliminate two small arrow.
To avoid the case you mentioned with when Choose a fill columns, you need to eliminate the big arrow that I highlighted by isolate the input$cols_fact in output$plot <- renderPlot{...} reactive.
With this you still have the plot refresh two time when choose data table but I think it acceptable as you need the plot to re-active when you do Choose numeric columns
Hope this answer your questions! Having fun playing arround with Shiny!
My R program works as expected. It shows a table containing my dataFrame, and lets me edit the values.
How do I capture those values and save them to my dataframe, or a copy of my dataframe?
require(shiny)
library(rhandsontable)
DF = data.frame(val = 1:10, bool = TRUE, big = LETTERS[1:10],
small = letters[1:10],
dt = seq(from = Sys.Date(), by = "days", length.out = 10),
stringsAsFactors = F)
rhandsontable(DF, rowHeaders = NULL)
EDIT:
The above code produces a table with rows and columns. I can edit any of the rows and columns. But when I look at my dataFrame, those edits do not appear. What I am trying to figure out is what do I need to change so I can capture the new values that were edited.
I know this thread's been dead for years, but it's the first StackOverflow result on this problem.
With the help of this post - https://cxbonilla.github.io/2017-03-04-rhot-csv-edit/, I've come up with this:
library(shiny)
library(rhandsontable)
values <- list()
setHot <- function(x)
values[["hot"]] <<- x
DF <- data.frame(val = 1:10, bool = TRUE, big = LETTERS[1:10],
small = letters[1:10],
dt = seq(from = Sys.Date(), by = "days", length.out = 10),
stringsAsFactors = FALSE)
ui <- fluidPage(
rHandsontableOutput("hot"),
br(),
actionButton("saveBtn", "Save changes")
)
server <- function(input, output, session) {
observe({
input$saveBtn # update dataframe file each time the button is pressed
if (!is.null(values[["hot"]])) { # if there's a table input
DF <<- values$hot
}
})
observe({
if (!is.null(input$hot)){
DF <- (hot_to_r(input$hot))
setHot(DF)
}
})
output$hot <- renderRHandsontable({
rhandsontable(DF) %>% # actual rhandsontable object
hot_table(highlightCol = TRUE, highlightRow = TRUE, readOnly = TRUE) %>%
hot_col("big", readOnly = FALSE) %>%
hot_col("small", readOnly = FALSE)
})
}
shinyApp(ui = ui, server = server)
However, I don't like my solution on the part of DF <<- values$hot as I previously had problems with saving changes to the global environment. I've couldn't figure it out any other way, though.
It seems to be accessible now via input$NAME_OF_rHandsontableOutput and can be converted to a data.frame via hot_to_r().
Reproducible example:
library(shiny)
library(rhandsontable)
ui <- fluidPage(
rHandsontableOutput("hottable")
)
server <- function(input, output, session) {
observe({
print(hot_to_r(input$hottable))
})
output$hottable <- renderRHandsontable({
rhandsontable(mtcars)
})
}
shinyApp(ui, server)
I was able to accomplish this with a more simple solution for saving data while the app is open and after it is closed for shiny 1.7++
Create an observe event dependent upon a save button clicked at any point when the app is open. I've scaled this method in more complex apps where you have a selectizeinput for swapping in and out different data frames into the rhandsontable, each of which are edited, saved and recalled while the app is open.
In the server:
observeEvent(input$save, { #button is the name of the save button, change as needed
df <<- hot_to_r(input$rhandsontable) #replace rhandsontable with the name of your own
}) #df is the data frame that have it access when the app starts
In the UI:
actionButton("save","Save Edits")
I don't know what you want to recover exactly, but this seems to work:
DF <- rhandsontable(DF, rowHeaders = NULL)
library(jsonlite)
fromJSON(DF$x$data)
If you are using Shiny then input$table$changes$changes can give you the edited value with row and column index. Below is the code if you want to update only specific cell and not the complete table using hot_to_t().
library(shiny)
library(rhandsontable)
DF = data.frame(val = 1:10, bool = TRUE, big = LETTERS[1:10],
small = letters[1:10],
dt = seq(from = Sys.Date(), by = "days", length.out = 10),
stringsAsFactors = F)
ui <- fluidPage(
rHandsontableOutput('table')
)
server <- function(input, output) {
X = reactiveValues(data = DF)
output$table <- rhandsontable::renderRHandsontable({
rhandsontable(X$data, rowHeaders = NULL)
})
observeEvent(input$table$changes$changes,{
row = input$table$changes$changes[[1]][[1]]
col = input$table$changes$changes[[1]][[2]]
value = input$table$changes$changes[[1]][[4]]
X$data[row,col] = value
})
}
shinyApp(ui, server)
Here's an example from related post How to add columns to a data frame rendered with rhandsontable in R Shiny with an action button?, which started with Tonio Liebrand's solution above but rendered reactively with columns added by the user via action button so you can see the table evolve and see how manual edits to the table stick around:
library(shiny)
library(rhandsontable)
myDF <- data.frame(x = c(1, 2, 3))
ui <- fluidPage(rHandsontableOutput('hottable'),
br(),
actionButton('addCol', 'Add'))
server <- function(input, output, session) {
EmptyTbl <- reactiveVal(myDF)
observeEvent(input$hottable, {
EmptyTbl(hot_to_r(input$hottable))
})
output$hottable <- renderRHandsontable({
rhandsontable(EmptyTbl())
})
observeEvent(input$addCol, {
newCol <- data.frame(c(1, 2, 3))
names(newCol) <- paste("Col", ncol(hot_to_r(input$hottable)) + 1)
EmptyTbl(cbind(EmptyTbl(), newCol))
})
}
shinyApp(ui, server)