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.
Related
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 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)
I am trying to get input choices dependent on previous input.
require(shiny)
require(dplyr)
dat <- data.frame(id1 = c(rep("A",5),rep("B",5)),
id2 = c(rep("C",3),rep("D",3),rep("E",4)),
id3 = c(rep("F",2),rep("G",3),rep("H",5)), stringsAsFactors=FALSE)
ui <- shinyUI(fluidPage(
sidebarPanel(
selectInput('id1', 'ID1', choices = unique(dat$id1)),
selectInput("id2", "ID2", choices = unique(dat$id2)),
selectInput("id3", "ID3", choices = unique(dat$id3))
)
)
)
server <- function(input, output,session) {
observeEvent(
{
input$id1
},{
input$id2
temp <- dat %>% filter(id1%in%input$id1)
updateSelectInput(session,"id2",choices = unique(temp$id2))
}
)
}
shinyApp(ui = ui, server = server)
This works for Input 1 and 2, however if i add another Input to observeEvent, the app chrashes. E.g:
server <- function(input, output,session) {
observeEvent(
{
input$id1
},{
input$id2
temp <- dat %>% filter(id1%in%input$id1)
updateSelectInput(session,"id2",choices = unique(temp$id2))
},{
input$id3
temp <- dat %>% filter(id1%in%input$id1 & id2%in%input$id2)
updateSelectInput(session,"id3",choices = unique(temp$id3))
}
)
}
How can I pass further Inputs to observeEvent ?
Update: I found a solution for the problem. I wrapped the Inputs in a reactive function, split the Output and passed it to the corresponding observeEvent functions.
server <- function(input, output,session) {
change <- reactive({
unlist(strsplit(paste(c(input$id1,input$id2,input$id3),collapse="|"),"|",fixed=TRUE))
})
observeEvent(input$id1,{
temp <- dat %>% filter(id1 %in% change()[1])
updateSelectInput(session,"id2",choices = unique(temp$id2))
}
)
observeEvent(input$id2,{
temp <- dat %>% filter(id1 %in% change()[1] & id2 %in% change()[2])
updateSelectInput(session,"id3",choices = unique(temp$id3))
}
)
}
In the below toy example I have two data sets df1 and df2. The data sets are output to an interactive table using shiny & rhandsontable. My issue is that the output$out only recognizes the shift in data sets if the user hasn't edited the data set in the shiny application as indicated by is.null(input$out).
How do I fix the below code to load either df1 or df2 when input$df changes when input$out isn't null?
require(rhandsontable)
require(shiny)
df1 <- data.frame(col1 = rnorm(20),
col2 = rep(T, 20))
df2 <- data.frame(col1 = rnorm(20),
col2 = rep(F, 20))
funcX <- function(x) {
x$out <- ifelse(x$col2 == T, x$col1 * 1.5, x$col1)
x$out
}
df2$out <- funcX(df2)
df1$out <- funcX(df1)
server <- function(input, output) {
df <- reactive({
if (input$df == "df1") {
df <- df1
} else {
df <- df2
}
df
})
output$out <- renderRHandsontable({
if (is.null(input$out)) {
hot <- rhandsontable(df())
} else {
str(input$out)
hot <- hot_to_r(input$out)
hot$out <- funcX(hot)
hot <- rhandsontable(hot)
}
hot
})
}
ui <- fluidPage(sidebarLayout(sidebarPanel(
selectInput(
'df', 'Select data.frame:',
choices = c('df1', 'df2'),
selected = 'df1'
)
),
mainPanel(rHandsontableOutput("out"))))
shinyApp(ui = ui, server = server)
You could use reactiveValues to store the df1 and df2 data frames, and update these values when they are modified. Here's an example server.R code:
server <- function(input, output) {
values = reactiveValues()
values[["df1"]] <- df1
values[["df2"]] <- df2
observe({
if (!is.null(input$out)) {
temp <- hot_to_r(input$out)
temp$out <- funcX(temp)
if (isolate(input$df) == "df1") {
values[["df1"]] <- temp
} else {
values[["df2"]] <- temp
}
}
})
df <- reactive({
if (input$df == "df1") {
df <- values[["df1"]]
} else {
df <- values[["df2"]]
}
df
})
output$out <- renderRHandsontable({
hot <- rhandsontable(df())
hot
})
}
When the table is changed, the correct df1 or df2 is updated in the reactive values. In the observer, the input$df is isolated so that this part of the code only reacts to when the user changes the tables.
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)