I am running into trouble using the tapply function. I am pulling two vectors from the same data frame which was created from a reactive variable. The first I am calling from a user inputted selection, and the second is one that I have created to keep my code generalisable and to use in my sort function. My sample code is shown below using the r-bloggers example. The data is here.
https://redirect.viglink.com/?format=go&jsonp=vglnk_150821851345614&key=949efb41171ac6ec1bf7f206d57e90b8&libId=j8v6cnh201021u9s000DAhzunvtas&loc=https%3A%2F%2Fwww.r-bloggers.com%2Fbuilding-shiny-apps-an-interactive-tutorial%2F&v=1&out=http%3A%2F%2Fdeanattali.com%2Ffiles%2Fbcl-data.csv&ref=https%3A%2F%2Fduckduckgo.com%2F&title=Building%20Shiny%20apps%20%E2%80%93%20an%20interactive%20tutorial%20%7C%20R-bloggers&txt=here
The error it throws is that they are not the same length, even though their attribute and class print outs are exactly the same.
I know that this is not the best code in the world, but I just threw together a quick example.
library(shiny)
library(tidyverse)
bcl <- read.csv("bcl-data.csv", stringsAsFactors = FALSE)
ui <- fluidPage(titlePanel("Sampling Strategies"),
sidebarLayout(
sidebarPanel(
selectInput("XDATA","xdata",
choices = c(names(bcl))),
selectInput("YDATA","ydata",
choices = c(names(bcl)))
),
mainPanel(
tabsetPanel(
tabPanel("The table",tableOutput("mytable"))
))
))
server <- function(input, output, session) {
filtered <- reactive({
bcl <- bcl %>% mutate(ID = 1:nrow(bcl))
})
output$mytable <- renderTable({
dataset <- filtered() %>% mutate(sampled = "white")
sample.rows <- sample(dataset$ID, 5, replace = FALSE)
dataset$sampled[sample.rows] <- "black"
final <- tapply(dataset[input$XDATA], list(dataset$sampled),mean)[["black"]]
return(final)
})
}
shinyApp(ui = ui, server = server)
Cheers
Edit* Sorry my bad, forgot to change over the drop list codes. All I am interested is one generic xdata vector that can be selected from the loaded data set. I then sample it, and want to find the mean value from the sampled indices.
One of the problems is in the subsetting. the [ still returns a data.frame. So, we need [[. If we look at ?tapply
tapply(X, INDEX, FUN = NULL, ..., default = NA, simplify = TRUE)
where
X is an atomic object, typically a vector
ui <- fluidPage(titlePanel("Sampling Strategies"),
sidebarLayout(
sidebarPanel(
selectInput("XDATA","xdata",
choices = c(names(bcl)[5:7])),
selectInput("YDATA","ydata",
choices = c(names(bcl)))
),
mainPanel(
tabsetPanel(
tabPanel("The table",tableOutput("mytable"))
))
))
server <- function(input, output, session) {
filtered <- reactive({
bcl <- bcl %>% mutate(ID = row_number())
})
output$mytable <- renderTable({
dataset <- filtered() %>% mutate(sampled = "white")
sample.rows <- sample(dataset$ID, 20, replace = FALSE)
dataset$sampled[sample.rows] <- "black"
final <- tapply(dataset[[input$XDATA]], list(dataset$sampled),mean, na.rm = TRUE, simplify = TRUE)
return(final)
})
}
shinyApp(ui = ui, server = server)
-output
Related
I am building a Shiny app that would take in numeric data (in a "handsontable" format) and make a boxplot out of the entered data. I would like to have an option to change column names (as "textInput") of the resulting "handsontable" and pass those names to the plot's "x" axis labels. While the code below works fine for changing names in the table I could not find a solution to pass those updated column names ("colHeaders") to the plot. I would very much appreciate a piece of advice. Many thanks!
edit: the app also calculates column means and saves PNG but that is unlikely to be related to my problem
library(shiny)
library(rhandsontable)
library(dplyr)
#UI
ui <- shinyUI(fluidPage(
titlePanel("Boxplot builder"),
textOutput('result'),
sidebarLayout(
sidebarPanel(
wellPanel(
plotOutput("plot")),
wellPanel(
h3("Build BoxPlot"),
actionButton("build", "Build")),
wellPanel(
h3("Export Plot"),
downloadButton('ExportPlot', 'Export as png')),
),
mainPanel(textInput("colnames", "Enter Column Names (separated by comma)",
value="", placeholder = "e.g. Var1, Var2, etc"),
h5(tags$b("Enter data")),
rHandsontableOutput('table'))
)))
rowNames <- c(sprintf("[%d]",seq(1:20)), "Means")
defaultDF <- data.frame(
row.names = rowNames,
A = rep(NA_integer_, nrow=21),
B = rep(NA_integer_, 21),
C = rep(NA_integer_, 21),
stringsAsFactors = FALSE)
#Server
server <- function(input, output, session)
({
values <- reactiveValues(data = defaultDF)
observe({
req(input$table)
DF <- hot_to_r(input$table)
DF[setdiff(rowNames, "Means"),]
DF["Means",] <- colMeans(DF[setdiff(rowNames, "Means"),], na.rm = TRUE)
values$data <- DF
})
output$table <- renderRHandsontable({
req(values$data)
rhandsontable(values$data, rowHeaderWidth = 100,
colHeaders=str_trim(unlist(strsplit(input$colnames,","))),) %>%
hot_row(nrow(values$data), readOnly = TRUE)
})
observeEvent(input$build, {
output$plot <- renderPlot({
boxplot(values$data)
})
})
#Export PNG
output$ExportPlot = downloadHandler(
filename = 'BoxPlot.png',
content = function(file) {
png(file)
boxplot(values$data)
dev.off()
})
})
shinyApp(ui = ui, server = server)
You can add names to your boxplot call:
boxplot(values$data, names = str_trim(unlist(strsplit(isolate(input$colnames),","))))
and provide the column names from input$colnames (after splitting by comma).
You might add isolate if you don't want the plot updated when names are changed unless the build button is pressed.
Also, you can create a separate reactive expression that returns the column names, such as:
my_col_names <- reactive({
str_trim(unlist(strsplit(isolate(input$colnames),",")))
})
and then call my_col_names() instead from plot, table, and wherever you need the column names so you don't need to repeat this code. Note that you may not want isolate if this expression should be evaluated when the column names change.
Code Below. I want to filter a data.frame based on two inputs. input$SelectGroup4 will be a column name in a data.frame and input$subsetSelect is a value in that column. Is this possible to do? Note: the whole code base is much much larger, so I took out only the key parts to this code. This code probably won't run on it's own, but it's just to get a general idea.
library(shiny)
library(data.table)
ui = fluidPage(
uiOutput('textField'),
uiOutput('docIdField'),
fluidRow(column(4,textInput("keyword", "Enter keyword :", "WB")),
fluidRow(column(4, sliderInput("context", "Enter number of words for context :",
min = 1, max = 10,
value = 5))),
fluidRow(column(4,uiOutput('selectGroup4'))),
fluidRow(column(4,uiOutput('subsetSelect'))),
fluidRow(column(10,DT::dataTableOutput("kwicTable"))))
}
server = function(input,output){
df_corpus1 <- reactive({
dTemp = as.data.table(datasetInput())
dTemp = dTemp %>% filter(input$selectGroup4==input$subsetSelect)
})
output$kwicTable=renderDataTable({
dtemp = df_corpus1()
dtemp = corpus(as.data.frame(dtemp),text_field=input$textField,docid_field=input$docIdField)
x = kwic(x = dtemp,pattern=input$keyword,window=input$context)
x = as.data.table(x)
x[,4:6]
})
}
shinyApp(ui,server)
Yes, you can do that. Since we do not have access to your dataset, here is a working example with the mtcars dataset.
Hope this helps!
library(shiny)
ui <- fluidPage(
selectInput('col','Column',colnames(mtcars)),
uiOutput('ui_col'),
dataTableOutput('table')
)
server <- function(input,output){
# Create a new input element with the unique values of the selected column
output$ui_col <- renderUI({
req(input$col)
selectizeInput('val','Value',unique(mtcars[[input$col]]),multiple=T)
})
# If both inputs are not null, filter the table
output$table <- renderDataTable({
df <- mtcars
if(!is.null(input$col) & !is.null(input$val))
{
df = df[df[[input$col]] %in% input$val,]
}
df
})
}
shinyApp(ui = ui, server = server)
I'm writing a shiny function that takes a dataset and generates UI components based upon the presence of design variables (factors) and response variables (numeric).
I would like to have a checkbox input to hide/show all of the variables in the app (the design UI element) and also be able to filter out particular rows based upon the levels of the design factors. Since the number of factors in a dataset is unknown, this has to be generated generically.
Within the function, before ui and server are defined, I find all of the factor variables and generate the relevant parameters for checkboxGroupInputs and then in ui use lapply and do.call to add them to the interface. However, I now need to use them to filter the rows and I'm not sure how to do so.
I've prepared a MWE to illustrate:
data(iris)
iris$Species2 <- iris$Species
filterex <- function(data = NULL){
library(shiny)
# Get design variables (factors) and response variables:
dvars <- names(which(sapply(data, class) == "factor"))
rvars <- names(which(sapply(data, class) != "factor"))
# Generate inputs for all design factor filters:
num_filters <- length(dvars)
filters <- list()
for (i in 1:num_filters){
filt <- dvars[[i]]
filters[[i]] <- list(inputId = filt, label = filt,
choices = levels(data[[filt]]),
selected = levels(data[[filt]]))
}
## UI #############################
ui = fluidPage(
titlePanel("Dynamic filtering example"),
sidebarPanel(
checkboxGroupInput(inputId = "design", label = "Design Variables",
choices = dvars, selected = dvars),
# Add filter checkboxes:
lapply(filters, do.call, what = checkboxGroupInput)),
mainPanel(
dataTableOutput("data"))
)
## SERVER #########################
server = function(input, output, session) {
# SUBSET DESIGN COLUMNS BASED UPON INPUTS:
dat_subset <- reactive({
df <- data[, c(input$design, rvars), drop = FALSE]
# NEED TO INCORPORATE CODE TO SUBSET ROWS HERE
return(df)
})
output$data <- renderDataTable({
dat_subset()
})
}
runApp(list(ui = ui, server = server))
}
filterex(iris)
My issues are:
[SOLVED] Even though it appears the filter checkboxes are being created (lines 11:19), I cannot get them to be included in the app as expected.
Once they are added, I'm not sure how to utilize them to filter the rows as needed around line 40 (e.g., should be able to uncheck setosa from Species to hide those rows).
Any advice would be really appreciated! I've looked at many other threads, but all the solutions I've come across are tailored for a particular dataset (so the number and names of the variables are known a priori).
Similar to your arrived solution, consider lapply over for loops in building filters and dynamic subsetting:
filterex <- function(data = NULL){
# Get design variables (factors) and response variables:
dvars <- names(which(sapply(data, class) == "factor"))
rvars <- names(which(sapply(data, class) != "factor"))
# Generate inputs for all design factor filters:
filters <- lapply(dvars, function(d) {
list(inputId = d, label = d,
choices = levels(data[[d]]),
selected = levels(data[[d]]))
})
## UI #############################
ui = fluidPage(
titlePanel("Dynamic filtering example"),
sidebarPanel(
checkboxGroupInput(inputId = "design", label = "Design Variables",
choices = dvars, selected = dvars),
# Add filter checkboxes:
lapply(filters, do.call, what = checkboxGroupInput)),
mainPanel(
dataTableOutput("data"))
)
## SERVER #########################
server = function(input, output, session) {
# SUBSET DESIGN COLUMNS BASED UPON INPUTS:
dat_subset <- reactive({
df <- data[, c(input$design, rvars), drop = FALSE]
# DF SUBSET LIST
dfs <- lapply(dvars, function(d) {
df[df[[d]] %in% input[[d]],]
})
# ROW BIND ALL DFs
df <- do.call(rbind, dfs)
return(df)
})
output$data <- renderDataTable({
dat_subset()
})
}
runApp(list(ui = ui, server = server))
}
filterex(iris)
If there is a better way of doing this, I would love to hear it but I have a working prototype! This can show/hide the design variables and filter the rows based upon the boxes that are checked/unchecked. Further, the UI elements for the filters are added/hidden based upon the design selection :)
filterex <- function(data = NULL){
# Get design variables (factors) and response variables:
dvars <- names(which(sapply(data, class) == "factor"))
rvars <- names(which(sapply(data, class) != "factor"))
data$internalid <- 1:nrow(data)
## UI #############################
ui = fluidPage(
titlePanel("Dynamic filtering example"),
sidebarPanel(
checkboxGroupInput(inputId = "design", label = "Design Variables",
choices = dvars, selected = dvars),
uiOutput("filters")),
mainPanel(
dataTableOutput("data"))
)
## SERVER #########################
server = function(input, output, session) {
# Determine checkboxes:
output$filters <- renderUI({
filters <- lapply(dvars[dvars == input$design], function(d) {
list(inputId = d, label = d,
choices = levels(data[[d]]),
selected = levels(data[[d]]))
})
lapply(filters, do.call, what = checkboxGroupInput)
})
# GENERATE REDUCED DATA TABLE:
dat_subset <- reactive({
# SUBSET DATA BY DESIGN INPUTS
df <- data[, c(input$design, rvars, "internalid"), drop = FALSE]
# SUBSET DATA BY ROWS AND MERGE
for (i in 1:length(input$design)){
if(!is.null(input[[input$design[[i]]]])){
dfs <- lapply(input$design, function(d) {
df[df[[d]] %in% input[[d]],]
})
if (length(dfs) > 1){
df <- Reduce(function(...) merge(..., all=FALSE), dfs)
} else df <- dfs[[1]]
}
}
return(df)
})
output$data <- renderDataTable({
dat_subset()[,c(input$design, rvars)]
})
}
runApp(list(ui = ui, server = server), launch.browser = TRUE)
}
data(iris)
iris$Species2 <- iris$Species
filterex(iris)
Here is one option using tidyverse
library(shiny)
library(dplyr)
library(purrr)
filterex <- function(data = NULL) {
i1 <- data %>%
summarise_all(is.factor) %>%
unlist()
dvars <- i1 %>%
names(.)[.]
rvars <- i1 %>%
`!` %>%
names(.)[.]
filters <-dvars %>%
map(~list(inputId = .,
label = .,
choices = levels(data[[.]]),
selected = levels(data[[.]])))
ui = fluidPage(
titlePanel("Dynamic filtering example"),
sidebarPanel(
checkboxGroupInput(inputId = "design",
label = "Design Variables",
choices = dvars,
selected = dvars),
map(filters, ~do.call(what = checkboxGroupInput, .))),
mainPanel(dataTableOutput("data"))
)
server = function(input, output, session) {
dat_subset <- reactive({
df <- data %>%
select(input$design, rvars)
dvars %>%
map2_df(list(df), ~.y %>%
filter_at(.x, all_vars(. %in% input[[.x]])))
})
output$data <- renderDataTable({
dat_subset()
})
}
runApp(list(ui = ui, server = server))
}
Using the function on 'iris'
filterex(iris)
Output got is
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)