Rhsiny: Automatically update an output object based on updated rhandsontable object - shiny

I have an app with two tables. One table is a renderhandsontable object and the other is just a rendertable object. I would like for when I update my renderhandsontable object for it to automatically update my rendertable object. My renderhandontable object is created by data elsewhere in the app using a number of filters.
I have referenced several very useful posts here to help me get this far in creating a reactive table that could be used in multiple output objects such as
How to render multiple output from the same analysis without executing it multiple time? (Shiny)
Get selected rows of Rhandsontable
Handsontable : how to change cell value in render function
but I cannot seem to get past this last hurdle. I also tried adding a button (using eventReactive) so the table would update when I pressed it rather than automatically, but had no luck there (and automatic would definitely be preferred).
I have created an overly simplified version of my server code below.
#dummy data
x = c('A','A','A', 'B','B', 'c')
y = c('G1', 'G1', 'G1', 'G2', 'G2','G3')
z = c('100', '200', '300', '400','500','600')
b=data.frame('Category' = x,
'Group' = y,
'Total' = z)
#create reactive object to be used in multiple places
test <- reactive({
t <-filter(b, b$Category %in% input$cat & b$Group %in% input$group)
return(t)
})
output$test_table <- renderTable({
tbl = data.frame(matrix(0, ncol = 4, nrow = 4))
#I know something needs to be done prior to this step to get updated values #of test()
tbl[1,1] <- test()[1,3]
return(tbl)
})
output$contents <- renderRHandsontable({
rhandsontable(test())
})
I can get my tables to appear properly and the data to update initially, but once I make an update to my table, it is not reflected in my second table.
I have really been struggling with this for quite some time so any help or hints would be greatly appreciated !

Please read this. You can access the rhandsontable params via input$my_id. To get the current data use input$my_id$params$data.
Here is what I think you are after:
library(shiny)
library(rhandsontable)
ui <- fluidPage(rHandsontableOutput("contents"),
tableOutput("test_table"),
tableOutput("test_table_subset"))
server <- function(input, output) {
# dummy data
x = c('A', 'A', 'A', 'B', 'B', 'C')
y = c('G1', 'G1', 'G1', 'G2', 'G2', 'G3')
z = c('100', '200', '300', '400', '500', '600')
b = data.frame('Category' = x,
'Group' = y,
'Total' = z)
# create reactive object to be used in multiple places
test <- reactive({
t <- b # dplyr::filter(b, b$Category %in% input$cat & b$Group %in% input$group)
return(t)
})
output$contents <- renderRHandsontable({
rhandsontable(test())
})
contentsTableDat <- reactive({
req(input$contents)
hot_to_r(input$contents)
})
output$test_table <- renderTable({
contentsTableDat()
})
output$test_table_subset <- renderTable({
contentsTableDat()[1, 3]
})
}
shinyApp(ui = ui, server = server)

Related

How to provide metadata values from server to ui method in shiny

I'm very new to shiny and butting against something there must be a pattern for, but have had no luck Googling.
I have a simple shiny file (app.R below) that returns a plot for n observations. In addition to making the plot available to the ui method, I'd like to pass it n to help it size the plot to my liking
library(shiny)
server <- function(input, output) {
output$distPlot <- renderPlot({
firstNames <- c("Bob", "Jane", "Bob")
lastNames <- c("Builder", "Gorillas", "Weave")
ages <- c(25, 26, 27)
df <- data.frame(firstNames, lastNames, ages)
# I want to pass this to `ui`
numFirstNames <- length(unique(df$firstNames))
mapping <- aes(x = firstNames, y = ages)
ggplot(df, mapping) + geom_violin() + coord_flip()
})
}
getHeightInPx <- function(numFirstNames) {
paste(100 * numFirstNames, "px", sep="")
}
ui <- fluidPage(
# I want height to be a function of numFirstNames as calculated in the server definition
mainPanel(plotOutput("distPlot", height = getHeightInPx(2)))
)
shinyApp(ui, server)
Since ui isn't a function and doesn't have direct access to output (to me it's getting to distPlot by framework magic) how can I get to data prepared in server to help layout the page?
Thanks
https://github.com/rstudio/shiny/issues/650 tipped me off that you could use the height parameter in renderPlot. So I combined that with some use of reactive and observe to call a function that returns the plot AND gives me the number of elements to use.
I hardly get reactive and observe, so while it seems to work I would not be surprised to hear that I am abusing them or that there's an easier way.
library(shiny)
renderDistPlot <- function(input) {
firstNames <- c("Bob", "Jane", "Bob", "Carol")
lastNames <- c("Builder", "Gorillas", "Weave", "Xmasing")
ages <- c(25, 26, 27, 23)
df <- data.frame(firstNames, lastNames, ages)
# I want to pass this to `ui`
numFirstNames <- length(unique(df$firstNames))
mapping <- aes(x = firstNames, y = ages)
plot <- ggplot(df, mapping) + geom_violin() + coord_flip()
list(Plot = plot, NumFirstNames = numFirstNames)
}
server <- function(input, output) {
renderDistPloatResult <- reactive(renderDistPlot(input))
observe(output$distPlot <- renderPlot(renderDistPloatResult()$Plot, height = renderDistPloatResult()$NumFirstNames * 100))
}
ui <- fluidPage(
# I want height to be a function of numFirstNames as calculated in the server definition
mainPanel(plotOutput("distPlot"))
)
shinyApp(ui, server)

Display a subset of a data frame in a Shiny app

New to Shiny, I am trying to create a very simple app respecting the following sequence of events:
(1) Upload a dataframe,
(2) Wait until the user set the filtering parameter (Category in the example below),
(3) Press a Go! button,
(4) Display the first rows of the subset data frame.
Let's say I have a file df.tab to upload and process.
df <- data.frame(Category=c("A","A","A","B","B","B"), X=c(1,2,3,1,2,3), Y=c(1,2,3,34,21,1))
df
Category X Y
1 A 1 1
2 A 2 2
3 A 3 3
4 B 1 34
5 B 2 21
6 B 3 1
write.table(df, file="df.tab", row.names=F, quote=F, sep="\t")
My app.R looks like:
library(shiny)
# Define UI ----
ui <- fluidPage(
sidebarLayout(
sidebarPanel(
fileInput("input_df",label=h4("Dataset")),
selectInput("category",h4("Category"), choices = list("A" = 1,"B" = 2),selected = 1),
actionButton("goButton",label = "Go!")
),
mainPanel(
tableOutput("view")
)
)
)
# Define server logic ----
server <- function(input, output) {
data <- eventReactive(
input$input_df,
{
File <- input$input_df
if(is.null(File)){
return(NULL)
}else{
df <- read.table(File$datapath, header = T, sep = "\t")
}
}
)
data_sub <- eventReactive(
input$category,
{
df_sub <- subset(data(), Category == input$category)
}
)
output$view <- renderTable(
{
head(data_sub())
}
)
}
# Run the app ----
shinyApp(ui = ui, server = server)
However, the app is either not responsive or does not display any rows.
Note that I created 2 distinct reactive events data and data_sub in order to avoid loading the file every time I select a different category (and potentially to avoid stack errors with a recursive function).
Any help would be greatly appreciated.
Here is a working server function. Use reactive, not eventReactive and it is quite straightforward.
NOTE that your example assumes you have a Category column, I modified below to make it work with anything.
# Define server logic ----
server <- function(input, output) {
dataset <- reactive({
File <- input$input_df
req(File)
read.table(File$datapath, header = TRUE, sep = "\t")
})
data_sub <- reactive({
if("Category" %in% names(dataset())){
subset(dataset(), Category == input$category)
} else {
dataset()
}
})
output$view <- renderTable({
head(data_sub())
})
}

how to manipulate dataframe in R shiny app

Please I need assistant concerning a shiny code. I want to manipulate a data frame input by separating them into column vector for computation but I keep getting this error
Warning in <reactive>(...): NAs introduced by coercion
the code is as follows
library(shiny)
ui <- fluidPage(
# dataset
data <- data.frame(e1 = c(3, 7, 2, 14, 66),
e2 = c(2, 16, 15, 66, 30),
n1 = c(18, 25, 45, 62, 81),
n2= c(20, 30, 79, 64, 89))
# Application title
titlePanel("Demo"),
# Sidebar with a slider input for number of bins
sidebarLayout(
sidebarPanel(
# Input: Upload file
fileInput(inputId = 'file', label = 'upload the file')
),
# Display Output
mainPanel(
uiOutput("final")
)
)
)
# Define server logic required to draw a histogram
server <- function(input, output) {
# separating the dataframe into 4 column vectors
e1 <- reactive(as.numeric(input$file[,1]))
e2 <- reactive(as.numeric(input$file[,2]))
n1 <- reactive(as.numeric(input$file[,3]))
n2 <- reactive(as.numeric(input$file[,4]))
# File Upload function
data <- reactive({
file1 <- input$file
if(is.null(file1)){return()}
read.table(file = file1$datapath, sep = ',', header = TRUE)
})
output$result <- renderUI({
y <- (e1()/n1()) - (e2()/n2())
lg_y <- log(y)
v2 <- ((n1() - e1())/e1() * n1()) + ((n2() - e2())/e2() * n2())
w <- 1/v2
w1 <- sum(w)
w2 <- sum(w^2)
c <- w1 - (w2/w1)
s2 <- w * lg_y
ybar <- sum(s2)/sum(w)
Q <- sum(w*((lg_y - ybar)^{2}))# Cochrane homogeneity test statistic
Q.pval <- reactive(pchisq(Q, k() - 1,lower.tail = FALSE))
Isqd <- max(100*((Q-(k()-1))/Q),0)
})
}
# Run the application
shinyApp(ui = ui, server = server)
I have searched almost every question on this forum and haven't seen where the question was answered. please I look forward to your help
Still can't run the code above because you don't define function k(). Also FYI, your renderUI is set for "result" but your uiOutput is set for "final".
You get the warning Warning in <reactive>(...): NAs introduced by coercion because your true data set probably includes a non-numeric in it. I did not get any issues with the data set you provided above.
There are a couple ways forward:
1) Write a function to remove all non-numerics before you process the data. See here for a few examples.
2) Just keep the warning, it is a warning after all so it won't stop your code from running. Currently it turns your non-numerics into NA
3) Use suppressWarnings() but that is usually not recommended.
I do have a suggestion to clean up your code though:
# File Upload function
data <- reactive({
file1 <- input$file
if(is.null(file1)){return()}
read.table(file = file1$datapath, sep = ',', header = TRUE, stringsAsFactors = FALSE)
})
# separating the dataframe into 4 column vectors
e1 <- reactive(as.numeric(data()[,1]))
e2 <- reactive(as.numeric(data()[,2]))
n1 <- reactive(as.numeric(data()[,3]))
n2 <- reactive(as.numeric(data()[,4]))

R Shiny dq_render_handsontable Error when adding columns and trying to Edit new columns' cells

I get an error while using shiny dq_render_handsontable which I guess it's a bug of the dq_shiny package. I would appreciate if anyone could know any work around.
I am trying to interactively update a table via an action button ("Generate" in the code below). The tables which I am trying to switch among, have different number of columns. All works up to the display of the new table, i.e., once I click on "Generate" I can see the new table with additional columns. BUT the problem is that once I try to edit the cells of the data frame with a more columns after editting the first one with less columns, the following error appear:
Warning: Error in [<-.data.frame: new columns would leave holes after existing columns
I guess that is certainly a bug of dq_render_handsontable that doesn't recognize the new columns added to handsontable. Anyone knows a workaround? Maybe refreshing the table before showing a new data frame with more columns?
I attach the peice of the code to reproduce the error:
library(shiny)
library(rhandsontable)
library(dqshiny)
library(rlang)
ui = fluidPage(
dq_handsontable_output("InputTable", 9)
,
# actionButton("render", "Render HoT"),
actionButton("simulationInput_2", "Generate"),
fluidRow(id="bigRow", class="hidden",
style="height:100vh;background:#ff8f00;")
)
server = function(input, output) {
hw <- c("Hello", "my", "funny", "world!")
data1 <- data.frame(A=hw, B=hw[c(2,3,4,1)], C=1:4, D=Sys.Date() - 0:3,
A2=hw, B2=hw[c(2,3,4,1)], C2=1:4, D2=Sys.Date() - 1:4,
stringsAsFactors = FALSE)
hw <- c("Hello", "my", "funny", "world!")
data2 <- data.frame(A=hw, B=hw[c(2,3,4,1)], C=1:4, D=Sys.Date() - 0:3,
# A2=NA, B2=NA, C2=NA, D2=NA,
stringsAsFactors = FALSE)
cont = 0
observeEvent(input$simulationInput_2, {
cont <<- cont+1
print(cont)
if(mod(cont,2)==0){
data <- data2
}else{
data <- data1
}
renderInputTable(data)
render_hot("InputTable")
})
renderInputTable <- function(data){
dq_render_handsontable(
"InputTable",
data, #"rand",
# filters = F, #c("S", "T", "R", "R"),
filters = rep(NA, ncol(data)),
table_param = list(rowHeaders = NULL, selectCallback = TRUE))
}
observeEvent(input$random_select, toggle("bigRow"))
observeEvent(input$render, render_hot("InputTable"))
}
shinyApp(ui, server)
I could overcome the problem by a trick which is renaming the dq_shiny table ID which is actually a bug of dq_render_handsontable:
library(shiny)
library(rhandsontable)
library(dqshiny)
library(rlang)
library(magrittr)
library(data.table)
ui = fluidPage(
tags$div(id="simulationInputTable_divOutside", style="padding:0px;margin:0px",
tags$div(id="simulationInputTable_divInside1", style="padding:0px;margin:0px",
dq_handsontable_output("InputTable1", 9)),
tags$div(id="simulationInputTable_divInside2", style="padding:0px;margin:0px",
dq_handsontable_output("InputTable2", 9)),
tags$div(id="simulationInputTable_divInside3", style="padding:0px;margin:0px",
dq_handsontable_output("InputTable3", 9))
)
,
# actionButton("render", "Render HoT"),
actionButton("simulationInput_2", "Generate"),
fluidRow(id="bigRow", class="hidden",
style="height:100vh;background:#ff8f00;")
)
server = function(input, output) {
columns <- c(1,2,3,4)
hw <- c("Hello", "my", "funny", "world!")
cont = 0
observeEvent(input$simulationInput_2, {
cont <<- cont+1
data1 <- data.frame(A=hw, B=hw[c(2,3,4,1)], C=1:4, D=Sys.Date() - 0:3,
A2=hw, B2=hw[c(2,3,4,1)], C2=1:4, D2=Sys.Date() - 1:4,
stringsAsFactors = FALSE)
name = paste0("InputTable",cont)
divName = paste0("simulationInputTable_divInside",cont-1)
hide(divName)
dq_render_handsontable(
name,
data1, #"rand",
# filters = F, #c("S", "T", "R", "R"),
filters = rep(NA, ncol(data1)),
table_param = list(rowHeaders = NULL, selectCallback = TRUE))
})
observeEvent(input$random_select, toggle("bigRow"))
observeEvent(input$render, render_hot("InputTable"))
}
shinyApp(ui, server)

How to save previous interaction using reactiveValues

I am developing a table which does some calculations each time that an action button is used. One column of my table depends on its previous value,
C_new <- C_old + B_new - A_new
For instance, if A=4, B=A+2 and C= C(-1) + B - A my expected results are
A B C
1 2 3
4 6 5
I have tried to save the previous value of column C using reactiveValue, as mentioned in How to “remember” information from the previous iteration when using reactiveTimer in Shiny?, but it doesn't work. I don't know where I am getting wrong.
Here is my code
library(shiny)
ui <- fluidPage(
sidebarPanel(textInput("c1","Example"),
actionButton("update", "Update Table")),
mainPanel(tableOutput("example"))
)
server <- function(input, output) {
C_old <- reactive(x=3)
values <- reactiveValues(df = data.frame(A=1, B=2, C=3))
newEntry <- observeEvent(input$update,{
A_new <- as.numeric(input$c1)
B_new <- A_new + 2
C_new <- isolate (C_old$x + B_new - A_new)
C_old$x <<- C_new
new <- data.frame(A=A_new,B=B_new, C=C_new)
# attach the new line to the old data frame here:
values$df <- rbind(values$df, new)
})
# Print the content of values$df
output$example <- renderTable({
return(values$df)
})
}
shinyApp(ui = ui, server = server)
Important to know, observeEvents (similar to observes) don't have outputs. You just observe a change and do something in their body, but nothing is supposed to be returned (this is different to reactive({ }), which also observes changes but has return values), useful link.
Isolate is not needed in observeEvent , because nothing triggers an update except for input$update (this is different to observe and reactive, where all changeable items in the body trigger an update).
Below is the solution to your problem. I used reactiveVal which stores one single updateable value (see ?reactiveVal for help). After clicking the action button, I retrieve the old table by calling values(), calculate all new values (beware, I need to use tail to get only the last C value) and attach the result to the old value before storing the extended table into values by calling values(new_df):
library(shiny)
ui <- fluidPage(
sidebarPanel(numericInput("c1","Example", 0),
actionButton("update", "Update Table")),
mainPanel(tableOutput("example"))
)
server <- function(input, output) {
# stores the current data frame, called by values() and set by values(new_data_table)
values <- reactiveVal(data.frame(A=1, B=2, C=3))
# update values table on button click
observeEvent(input$update,{
old_values <- values()
A_new <- input$c1
B_new <- A_new + 2
C_new <- tail(old_values$C, 1) + B_new - A_new # tail to get the last C value
new_values <- data.frame(A=A_new, B=B_new, C=C_new)
# attach the new line to the old data frame here:
new_df <- rbind(old_values, new_values)
#store the result in values variable
values(new_df)
})
# Print the content of values$df
output$example <- renderTable({
return(values())
})
}
shinyApp(ui = ui, server = server)