I have the following sample app and I need to be able to switch inputs for multiple_choice_1_source OR multiple_choice_2_type without breaking the app and hiding submit_request_button_ui and ColnamesInput when the inputs from change. Basically, the user should be able to revise the inputs after clicking the "submit" button and the app should reset to its previous state.
What I have tried:
shinyjs() - this just hides and does not clear the inputs. This means that once I press the submit_request_button then any change made to multiple_choice_2_type is still processed and reacted upon. In the actual app, I have the submit tied to very large tables. I want to prevent the fetch for
selected_data() from re-running and clear and hide the elements that were created in the first two choices.
reactive - I tried to make the observers listen to some reactive triggers that take dependencies from more than one input. I used user_input_rv to store the values etc but this fails as the observers are triggered more than once, so when I click the submit button, the if statements within the reactive({}) are triggered twice, essentially downloading each dataset more than once. Also it fails.
isolate - I have not been able to make this work. I tried multiple combinations of isolate with no success.
library(shiny)
library(tidyverse)
ui <- fluidPage(
selectizeInput(inputId ='multiple_choice_1_source',
choices = c("db1","db2","db3","db4"), # like this because we want the selected to be blank on initialisation
label = "1. Select source",
multiple = FALSE,
size = 10,
width = '100%'
)
,uiOutput(outputId="multiple_choice_2_type_ui")
,uiOutput(outputId="submit_request_button_ui")
,uiOutput(outputId="ColnamesInput")
)
server <- function(input, output)
{
user_input_rv = reactiveValues(
source_picked = NULL,
last_used_source = NULL,
type_picked = NULL,
series_picked = NULL,
last_used_series = NULL,
selected_data = NULL,
final_selection = NULL
)
observeEvent(input$multiple_choice_1_source, {
user_input_rv$source_picked <- input$multiple_choice_1_source
#change data loaded under type picked.
user_input_rv$type_picked <-
if ( input$multiple_choice_1_source == "db1"){ paste0(colnames(mtcars))
} else if ( input$multiple_choice_1_source == "db2"){ paste0(colnames(diamonds))
} else if ( input$multiple_choice_1_source == "db3"){ NULL
} else if ( input$multiple_choice_1_source == "db4"){ NULL
}
output$multiple_choice_2_type_ui <- renderUI({
selectizeInput( inputId = 'multiple_choice_2_type',
choices = paste(user_input_rv$type_picked),
label= "2. Select type",
multiple = TRUE,
size = 10,
width = '100%',
options = list( placeholder = 'Type',
maxItems =1
)
)
})
}) #first observeEvent for source type and data load.
observeEvent(input$multiple_choice_2_type,{
output$submit_request_button_ui <- renderUI({
actionButton(
inputId = "submit_request_button",
label = " Get data "
)
})
})#second observeEvent for submit_request_button_ui
observeEvent(input$submit_request_button, {
selected_data <- reactive({
if( input$multiple_choice_1_source =="db1"){
mtcars
} else if ( input$multiple_choice_1_source == "db1") {
diamonds
} else if ( input$multiple_choice_1_source == "db3") { NULL
} else if ( input$multiple_choice_1_source == "db4"){ NULL
}
})
user_input_rv$series_picked <- input$multiple_choice_2_type
user_input_rv$selected_data <- selected_data()
min_cols <- as.integer(1) # default 1
max_cols <- as.integer(length(colnames(selected_data())))
#print(max_cols)
#this renderUI creates the right-hand side column of the app COLUMNS
output$ColnamesInput <- renderUI({
lapply(min_cols:max_cols, function(z) {
column(width = 3,
offset = 0,
selectInput( inputId = paste0("cols","_",z),
label = paste(input$multiple_choice_2_type,": ",colnames(selected_data())[z]),
choices = unique(selected_data()[[z]]),
multiple = TRUE
) #selectizeInput
)
})#lapply inner
}) #renderUI for columns
}) #third observeEvent for data selection and customisation
}
shinyApp(ui = ui, server = server)
Here is a the code in which I have removed the reactive expression from and used a local variable selected_data instead.
observeEvent(input$submit_request_button, {
# selected_data <- reactive({
# browser()
selected_data <- NULL
if( input$multiple_choice_1_source =="db1"){
selected_data <- mtcars
} else if ( input$multiple_choice_1_source == "db1") {
selected_data <- diamonds
} else if ( input$multiple_choice_1_source == "db3") { selected_data <- NULL
} else if ( input$multiple_choice_1_source == "db4"){selected_data <- NULL
}
# })
user_input_rv$series_picked <- isolate(input$multiple_choice_2_type)
user_input_rv$selected_data <- selected_data
min_cols <- as.integer(1) # default 1
max_cols <- as.integer(length(colnames(selected_data)))
#print(max_cols)
#this renderUI creates the right-hand side column of the app COLUMNS
output$ColnamesInput <- renderUI({
lapply(min_cols:max_cols, function(z) {
column(width = 3,
offset = 0,
selectInput( inputId = paste0("cols","_",z),
label = paste(isolate(input$multiple_choice_2_type),": ",colnames(selected_data)[z]),
choices = unique(selected_data[[z]]),
multiple = TRUE
) #selectizeInput
)
})#lapply inner
}) #renderUI for columns
}) #third observeEvent for data selection and customisation
Now when you change the select input options the ColnamesInput do not get triggered. It gets triggered only after you click the submit button.
[EDIT]:
Might not be the best method, but I think I am able to achieve what you wanted. Also, I have taken the liberty on using the reactiveValue that was already defined in your server. Have a look at the modified server code below:
server <- function(input, output)
{
user_input_rv = reactiveValues(
source_picked = NULL,
last_used_source = NULL,
type_picked = NULL,
series_picked = NULL,
last_used_series = NULL,
selected_data = NULL,
final_selection = NULL
)
observeEvent(input$multiple_choice_1_source, {
user_input_rv$source_picked <- input$multiple_choice_1_source
###Start: To check if the source changed#########
if(!is.null(user_input_rv$last_used_source))
{
if(user_input_rv$last_used_source != user_input_rv$source_picked)
{
shinyjs::hide("ColnamesInput")
user_input_rv$last_used_source = user_input_rv$source_picked
}
}else
{
user_input_rv$last_used_source = user_input_rv$source_picked
}
###End: To check if the source changed#########
#change data loaded under type picked.
user_input_rv$type_picked <-
if ( input$multiple_choice_1_source == "db1"){ paste0(colnames(mtcars))
} else if ( input$multiple_choice_1_source == "db2"){ paste0(colnames(diamonds))
} else if ( input$multiple_choice_1_source == "db3"){ NULL
} else if ( input$multiple_choice_1_source == "db4"){ NULL
}
output$multiple_choice_2_type_ui <- renderUI({
selectizeInput( inputId = 'multiple_choice_2_type',
choices = paste(user_input_rv$type_picked),
label= "2. Select type",
multiple = TRUE,
size = 10,
width = '100%',
options = list( placeholder = 'Type',
maxItems =1
)
)
})
}) #first observeEvent for source type and data load.
observeEvent(input$multiple_choice_2_type,{
###Start: To check if the series changed#########
user_input_rv$series_picked <- input$multiple_choice_2_type
if(!is.null(user_input_rv$last_used_series))
{
if(user_input_rv$last_used_series != user_input_rv$series_picked)
{
shinyjs::hide("ColnamesInput")
user_input_rv$last_used_series = user_input_rv$series_picked
}
}else
{
user_input_rv$last_used_series = user_input_rv$series_picked
}
###End: To check if the series changed#########
output$submit_request_button_ui <- renderUI({
actionButton(
inputId = "submit_request_button",
label = " Get data "
)
})
})#second observeEvent for submit_request_button_ui
observeEvent(input$submit_request_button, {
# selected_data <- reactive({
# browser()
shinyjs::show("ColnamesInput")
selected_data <- NULL
if( input$multiple_choice_1_source =="db1"){
selected_data <- mtcars
} else if ( input$multiple_choice_1_source == "db1") {
selected_data <- diamonds
} else if ( input$multiple_choice_1_source == "db3") { selected_data <- NULL
} else if ( input$multiple_choice_1_source == "db4"){selected_data <- NULL
}
# })
user_input_rv$series_picked <- isolate(input$multiple_choice_2_type)
user_input_rv$selected_data <- selected_data
min_cols <- as.integer(1) # default 1
max_cols <- as.integer(length(colnames(selected_data)))
#print(max_cols)
#this renderUI creates the right-hand side column of the app COLUMNS
output$ColnamesInput <- renderUI({
lapply(min_cols:max_cols, function(z) {
column(width = 3,
offset = 0,
selectInput( inputId = paste0("cols","_",z),
label = paste(isolate(input$multiple_choice_2_type),": ",colnames(selected_data)[z]),
choices = unique(selected_data[[z]]),
multiple = TRUE
) #selectizeInput
)
})#lapply inner
}) #renderUI for columns
}) #third observeEvent for data selection and customisation
}
Hope it helps!
Related
I have an R6 class that I am using to organize my shiny application. Essentially, I want to connect different R6 classes for an experimental interface I am creating and want to reuse my code. As a simplified working example, see the code below.
library(R6)
library(stringi)
library(shiny)
df <- data.frame(dp = c("dp1", "dp2", "dp3"), desc = c("problem 1", "problem 2", "problem 3"))
app <- R6::R6Class(classname = "App",
private = list(
#unique string id
..id = stringi::stri_rand_strings(1, 18),
#the data to be iterated through
..df = df,
#counter to update text
..counter = 1,
#initiating the dp and desc
..dp = 'dp1',
..desc = 'problem 1',
#the underlying server, to be created like a normal server
.server = function(input, output, session){
output$text <- renderText({
private$..desc
})
observeEvent(input$button, {
private$..counter <- private$..counter + 1
self$update_private()
#check the private content since the print is not updating
print(private$..counter)
print(private$..dp)
print(private$..desc)
})
}
),
public = list(
#create names for ui elements
button = NULL,
text = NULL,
initialize = function(){
self$button <- self$get_id("button")
self$text <- self$get_id("text")
self$update_private()
},
#gives ui outputs unique names tied to the user's id
get_id = function(name, ns = NS(NULL)){
ns <- NS(ns(private$..id))
id <- ns(name)
return(id)
},
#automatically updates the private field based on the counter
update_private = function(){
if(private$..counter == 1){
private$..dp <- "dp1"
} else if(private$..counter == 2){
private$..dp <- "dp2"
} else{
private$..dp <- "dp3"
}
private$..desc <- private$..df[private$..df$dp == private$..dp, "desc"]
},
ui = function(){
fluidPage(
h1("An Example"),
mainPanel(
textOutput(self$text)),
sidebarPanel(
shiny::actionButton(inputId = self$button,
label = 'Update!',
width = '100%'
))
)
},#end ui
server = function(input, output, session){
callModule(module = private$.server, id = private$..id)
}
)
)
test <- app$new()
ui <- test$ui()
server <- function(input, output, session) {
test$server()
}
shinyApp(ui = ui, server = server)
What I want: when someone clicks the action button, the reactive ui will update and the desired text from the data frame will be sliced and displayed.
What I am getting: the internal private data fields are updating but the reactive ui elements are not.
Any ideas what could be causing this or a workaround? I thought about externally trying to use the observe event and then reinitiating the class with a new counter number. But I also can't seem to figure out that option either.
Appreciate your help!
For anyone that comes across this problem... I figured out that even though the private is updating, and even though render is technically a reactive environment, you need to have your data stored publically in a reactive field.
library(R6)
library(stringi)
library(shiny)
df <- data.frame(dp = c("dp1", "dp2", "dp3"), desc = c("problem 1", "problem 2", "problem 3"))
app <- R6::R6Class(classname = "App",
private = list(
#unique string id
..id = stringi::stri_rand_strings(1, 18),
#the data to be iterated through
..df = df,
#counter to update text
..counter = 0,
#initiating the dp and desc
..dp = NA,
..desc = NA,
#the underlying server, to be created like a normal server
.server = function(input, output, session){
output$text <- renderText({
self$desc$text
})
observeEvent(input$button, {
private$..counter <- private$..counter + 1
self$update_private()
self$desc$text <- private$..desc
#check the private content since the print is not updating
print(private$..counter)
print(private$..dp)
print(private$..desc)
})
}
),
active = list(
.counter = function(value){
if(missing(value)){
private$..counter
}else{
private$..counter <- value
}
}
),
public = list(
#create names for ui elements
button = NULL,
text = NULL,
#Need this to update the text***************
desc = reactiveValues(text = NA),
initialize = function(counter = self$.counter){
self$.counter <- counter
self$button <- self$get_id("button")
self$text <- self$get_id("text")
self$update_private()
self$desc$text <- private$..desc
},
#gives ui outputs unique names tied to the user's id
get_id = function(name, ns = NS(NULL)){
ns <- NS(ns(private$..id))
id <- ns(name)
return(id)
},
#automatically updates the private field based on the counter
update_private = function(){
if(private$..counter == 1){
private$..dp <- "dp1"
} else if(private$..counter == 2){
private$..dp <- "dp2"
} else{
private$..dp <- "dp3"
}
private$..desc <- private$..df[private$..df$dp == private$..dp, "desc"]
},
ui = function(){
fluidPage(
h1("An Example"),
mainPanel(
textOutput(self$text)),
sidebarPanel(
shiny::actionButton(inputId = self$button,
label = 'Update!',
width = '100%'
))
)
},#end ui
server = function(input, output, session){
counter <- reactiveVal(private$..counter)
callModule(module = private$.server, id = private$..id)
}
)
)
test <- app$new(counter = 1)
ui <- test$ui()
server <- function(input, output, session) {
test$server()
}
shinyApp(ui = ui, server = server)
I am trying to create a modal that diplays text dynamically. Below is a reprex of what I'm thinking. My actual example I am creating a datatable based on reactive user input and interacting with a sql database so creating it in global environment is not desirable. Is there an easy way I can access the dataframe within the randerDataTable? My code below creates an error because table is not a dataframe object. I know renderDataTable does not create a dataframe, rather it creates an html table. Can I still access the data similiarly to a dataframe or parse it into a dataframe?
shinyApp(
ui = basicPage(
dataTableOutput("table")
),
server = function(input, output, session) {
output$table <- renderDataTable({
t <- data.frame(
x = rep(c('dog', 'cat', 'pig'),5),
y = rnorm(15),
z = rnorm(15)
)
DT::datatable(t, rownames=F, selection = 'none', options = list('tipl')) %>%
formatStyle(3, cursor = 'pointer')})
#Display the value of the cell in a modal
observeEvent(input$table_cell_clicked, {
info = input$table_cell_clicked
# do nothing if not clicked yet, or the clicked cell is not in the 1st column
if (is.null(info$value) || info$col != 2) return()
showModal(modalDialog(
title = paste("The animal you selected is:", table$x[info$row]), #creates an error because table is not a df object. Would like to do something like this though.
paste("The value of the cell is:", info$value),
easyClose = TRUE,
footer = NULL
))
})
}
)
You could use a global variable for this :
server = function(input, output, session) {
global_table <- NULL
output$table <- renderDataTable({
global_table <<- data.frame(
x = rep(c('dog', 'cat', 'pig'),5),
y = rnorm(15),
z = rnorm(15)
)
DT::datatable(global_table, rownames=F, selection = 'none', options = list('tipl')) %>%
formatStyle(3, cursor = 'pointer')})
#Display the value of the cell in a modal
observeEvent(input$table_cell_clicked,{
info = input$table_cell_clicked
warning(info$row )
# do nothing if not clicked yet, or the clicked cell is not in the 1st column
if (is.null(info$value) || info$col != 0) return()
showModal(modalDialog(
title = paste("The animal you selected is:", global_table$x[info$row]),
paste("The value of the cell is:", info$value),
easyClose = TRUE,
footer = NULL
))
})
}
But it's more elegant to use a reactive to compute the data
server = function(input, output, session) {
reactive_table <- reactive(
data.frame(
x = rep(c('dog', 'cat', 'pig'),5),
y = rnorm(15),
z = rnorm(15)
))
output$table <- renderDataTable({
DT::datatable(reactive_table(), rownames=F, selection = 'none',
options = list('tipl')) %>%
formatStyle(3, cursor = 'pointer')})
#Display the value of the cell in a modal
observeEvent(input$table_cell_clicked,{
info = input$table_cell_clicked
warning(info$row )
# do nothing if not clicked yet, or the clicked cell is not in the 1st column
if (is.null(info$value) || info$col != 0) return()
showModal(modalDialog(
title = paste("The animal you selected is:", reactive_table()$x[info$row]),
paste("The value of the cell is:", info$value),
easyClose = TRUE,
footer = NULL
))
})
}
I really had trouble finding a title for this question, hope it helps.
I have a fairly complex app for which I'm having trouble resetting an output after an actionButton ("Confirm" on this example) triggers the re-evaluation of a reactiveValues number that feeds a reactive table.
This causes that the selected table only renders once and no matter how many times the table that feeds it changes, it keeps showing the same result as the first time it was rendered.
It will be easy for you to see what I mean from this example. Believe me, it is the minimax from the one I'm coming from:
library(shiny)
library(DT)
ui <- fluidPage(
DTOutput("table"),
actionButton("checkvalues", "Check")
)
server <- function(input, output, session) {
primedata <- reactiveValues(data = NULL)
primedata$data <- as.numeric(Sys.time()) %% 10000
tabledata <- reactive({
data <- data.frame(rep(primedata$data, 5))
for (i in 1:5) {
data$V1[i] <- as.character(selectInput(paste0("sel", i), "",
choices = c("None selected" = 0,
"Icecream", "Donut"),
selected = 0, width = "120px"))
}
return(data)
})
output$table <- renderDataTable( #Generar tabla
tabledata(), filter = 'top', escape = FALSE, selection = 'none', server = FALSE,
callback = JS("table.rows().every(function(i, tab, row) {
var $this = $(this.node());
$this.attr('id', this.data()[0]);
$this.addClass('shiny-input-container');
});
Shiny.unbindAll(table.table().node());
Shiny.bindAll(table.table().node());")
)
# helper function for reading inputs in DT
shinyValue = function(id, len) {
unlist(lapply(seq_len(len), function(i) {
value = input[[paste0(id, i)]]
if (is.null(value)) NA else value
}))
}
observeEvent(input$checkvalues, {
datos <- tabledata()
selected <- cbind(datos, data.frame(N = shinyValue("sel", nrow(datos))))
selected <- selected %>% group_by(N) %>% summarise("see" = n())
showModal(modalDialog(
title = HTML('<h3 style="text-align:center;">Problem: this table will keep showing the same results as the first one presented</h3>'),
renderDT(datatable(selected, options = list(dom = 't', ordering = F))),
footer = actionButton("Confirm", "Confirm")))
})
observeEvent(input$Confirm, {
primedata$data <- as.numeric(Sys.time()) %% 10000
removeModal()
})
}
shinyApp(ui, server)
When you change primedata$data (by clicking on the Confirm button) this re-renders the table, and you have to unbind before:
ui <- fluidPage(
tags$head(tags$script(
HTML(
"Shiny.addCustomMessageHandler('unbindDT', function(id) {
var $table = $('#'+id).find('table');
if($table.length > 0){
Shiny.unbindAll($table.DataTable().table().node());
}
})")
)),
DTOutput("table"),
actionButton("checkvalues", "Check")
)
observeEvent(input$Confirm, {
session$sendCustomMessage("unbindDT", "table")
primedata$data <- as.numeric(Sys.time()) %% 10000
removeModal()
})
I have a shiny app like below using diamonds dataset as an example. I'm using two selectInput as data filter. The first one select a variable. The second one shows the values, depending on the variable selected in the first selectInput. After selection, click the actionButton to trigger the filter. Without any variable and value selected, I want it output the whole dataset.
What I found is after I clear the two selectInput and then click the actionButton, I got error: argument 1 is empty. I do not understand why that happens. Spent hours but unable to find the solution. Do anyone know how I can fix it? Thanks a lot!
library(shiny)
library(shinydashboard)
library(dplyr)
library(rlang)
data(diamonds)
df = diamonds[1:1000,]
subset_data = function(data,
var=NULL,
value=NULL){
if (!is.null(var)) {
if(!is.null(value)) {
data = data %>% filter(!!sym(var) == value)
}
}
return(data)
}
ui <- dashboardPage(
dashboardHeader(title = "example"),
dashboardSidebar(),
dashboardBody(
fluidRow(
selectizeInput(inputId = 'var',
label='Select variable',
choices = c('cut', 'color'),
multiple=FALSE,
options = list(
maxItems = 1,
placeholder = '',
onInitialize = I("function() { this.setValue(''); }"))),
uiOutput("valueUI"),
actionButton('go', 'apply filter'),
tableOutput('table')
)
)
)
server <- function(input, output, session) {
output$valueUI = renderUI({
if (input$var == '') {
vals = ''
}
if (input$var == 'cut') {
vals = c('Premium', 'Good', 'Very Good', 'Fair')
}
if (input$var == 'color'){
vals = c('E', 'J', 'I', 'H')
}
selectizeInput(inputId = 'value',
label='Select values',
choices = c('',vals),
multiple=FALSE,
options = list(
maxItems = 1,
placeholder = '',
onInitialize = I("function() { this.setValue(''); }")))
})
dat = reactive({
input$go
isolate( subset_data(data=df, var=input$var, value=input$value) )
})
output$table <- renderTable({
dat()
})
}
shinyApp(ui, server)
if input$var not given, it will be handled with '' as you implemented.
However, in same time it will also give parameter var value in subset_data function as '' not NULL, so it will be not recognized with !is.null(var) and trigger filter for data .
You can see these explanation if you change subset_data like below code;
subset_data = function(data,
var=NULL,
value=NULL){
print('var:')
print(var) # var is given as ''
print("value:")
print(value)
if (!is.null(var)) {
if(!is.null(value)) {
print('hi')
data = data %>% filter(!!sym(var) == value)
print('hi2') # this will not printed, since filter makes error.
}
}
return(data)
}
so in this case, you can fix them with adding just 1 line on subset_data to check if var == ''.
if( var == '' ) return(data)
Regards.
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)