shiny sliderInput from max to min - r

Is it possible to make a sliderInput that shows the values in decreasing order (from left to right; eg. 5 4 3 2 1)?
runApp(
list(
ui = fluidPage(
sliderInput("test","", min=5, max=1, value = 3, step=1)
),
server = function(input,output) {}
)
)

EDIT 2017-10-13: This function is now available in package shinyWidgets (with a different name : sliderTextInput()).
Hi you can write your own slider function like this (it's a little dirty...) :
sliderValues <- function (inputId, label, values, from, to = NULL, width = NULL) {
sliderProps <- shiny:::dropNulls(list(class = "js-range-slider",
id = inputId,
`data-type` = if (!is.null(to)) "double",
`data-from` = which(values == from) - 1,
`data-to` = if (!is.null(to)) which(values == to) - 1,
`data-grid` = TRUE,
`data-values` = paste(values, collapse = ", ")
))
sliderProps <- lapply(sliderProps, function(x) {
if (identical(x, TRUE))
"true"
else if (identical(x, FALSE))
"false"
else x
})
sliderTag <- div(class = "form-group shiny-input-container",
style = if (!is.null(width))
paste0("width: ", validateCssUnit(width), ";"),
if (!is.null(label))
shiny:::controlLabel(inputId, label), do.call(tags$input,
sliderProps))
dep <- list(htmltools::htmlDependency("ionrangeslider", "2.0.12", c(href = "shared/ionrangeslider"),
script = "js/ion.rangeSlider.min.js",
stylesheet = c("css/ion.rangeSlider.css",
"css/ion.rangeSlider.skinShiny.css")))
htmltools::attachDependencies(sliderTag, dep)
}
The point to do this is to use the values attribute from ionrangeslider (see section Using custom values array here)
The downside is the value of the input you retrieve server-side isn't the value of the slider but the index of the value (starting from 0).
You can use this function like this :
library("shiny")
runApp(
list(
ui = fluidPage(
# you have to pass the values you want in the slider directly to th function
sliderValues(inputId = "test", label = "", from = 5, values = 5:1),
verbatimTextOutput(outputId = "slidervalue")
),
server = function(input,output) {
output$slidervalue <- renderPrint({
# Careful ! : input$test isn't the expected value !!!
(5:1)[input$test + 1]
})
}
)
)
And bonus : it works with characters vectors too :
runApp(
list(
ui = fluidPage(
sliderValues(inputId = "test", label = "", from = "g", to = "o", values = letters),
verbatimTextOutput(outputId = "slidervalue")
),
server = function(input,output) {
output$slidervalue <- renderPrint({
# Careful ! : input$test isn't the expected value !!!
letters[input$test + 1]
})
}
)
)

Related

Arithmetic with shiny input

I have simulated annealing function which finds the global minimum. I am taking inputs from a shiny dashboard and I have radiobuttons to choose between minimise and maximise. I want to be able to find the global maximum by simply multiplying my input equation by -1. How can I do this arithmetic in shiny. Here is what I have so far but not sure what to put in the else if statement.
This is from the UI:
textInput("ObjectiveFun",
h3("Objective Function"),
value = "(x+2*y-7)^2+(2*x+y-5)^2"),
radioButtons("maxormin",
h3("Goal"),
choices=c("Minimise"="min", "Maximise"="max")),
This is from the server:
observeEvent(input$maxormin,{
if(input$maxormin == min)
{
Func <- input$ObjectiveFn
}
else if(input$maxormin == max)
{
#trying to get: Func <- input$-1*(ObjectiveFn)
}
})
Here is the entire shiny app so far:
library(shiny)
source("simulated_annealing.R")
ui <- fluidPage(
titlePanel("Simulated Annealing App"),
sidebarLayout(
position = "left",
sidebarPanel("User input",
textInput("ObjectiveFun",
h3("Objective Function"),
value = "(x+2*y-7)^2+(2*x+y-5)^2"),
radioButtons("maxormin",
h3("Goal"),
choices=c("Minimise"="min", "Maximise"="max")),
numericInput("XL",
h3("Lower bound of x"),
value = -5),
numericInput("XU",
h3("Upper bound of x"),
value = 5),
numericInput("YL",
h3("Lower bound of y"),
value = -5),
numericInput("YU",
h3("Upper bound of y"),
value = 5),
numericInput("TEMP",
h3("Starting temperature"),
value = 100),
numericInput("NEPOCHS",
h3("Number of epochs"),
value = 25),
numericInput("NITER",
h3("Maximum number of iterations per epoch"),
value = 8),
numericInput("AMIN",
h3("Minimum number of moves per epoch"),
value = 3),
sliderInput(
"ALPHA",
h3("Cooling rate"),
min=0,
max=1,
value=0.95,
step = NULL,
round = FALSE,
ticks = TRUE,
animate = FALSE,
width = NULL,
sep = ",",
pre = NULL,
post = NULL,
timeFormat = NULL,
timezone = NULL,
dragRange = TRUE
),
actionButton("Go","Simulate"),
),
mainPanel("System Outputs",
textOutput("value")
)
),
)
server <- function(input, output)
{
Sim <- eventReactive(input$Go, {
xlower <- input$XL
xupper <- input$XU
ylower <- input$YL
yupper <- input$YU
temp <- input$TEMP
alpha <- input$ALPHA
nepochs <- input$NEPOCHS
I <- input$NITER
A <- input$AMIN
observeEvent(input$maxormin,{
if(input$maxormin == min)
{
Func <- input$ObjectiveFn
}
else if(input$maxormin == max)
{
}
})
value <- simannealing(Func,goal,temp,I,A,alpha,nepochs,xlower,xupper,ylower,yupper)
paste("Final value is:", value[3],"at x value: ", value[1], "and y value: ", value[2])
})
output$FinalValues <- renderText({
Sim()
})

Pass reactive table to function to be printed via action button

I have a R shinydashboard where a table can be edited and then I'd like the new table to be passed to the function agree() to calculate a statistic to be printed upon clicking an action button. I'm getting the following error in my renderPrint box on the app and assume a few things may be off in my code:
Error message in renderPrint box on app:
structure(function (...) ,{, if (length(outputArgs) != 0 && !hasExecuted$get()) {, warning("Unused argument: outputArgs. The argument outputArgs is only ", , "meant to be used when embedding snippets of Shiny code in an ", , "R Markdown code chunk (using runtime: shiny). When running a ", , "full Shiny app, please set the output arguments directly in ", , "the corresponding output function of your UI code."), hasExecuted$set(TRUE), }, if (is.null(formals(renderFunc))) , renderFunc(), else renderFunc(...),}, class = "function", outputFunc = function (outputId, placeholder = FALSE) ,{, pre(id = outputId, class = "shiny-text-output", class = if (!placeholder) , "noplaceholder"),}, outputArgs = list(), hasExecuted = <environment>, cacheHint = list(, label = "renderPrint", origUserExpr = agree(as.data.frame(table1))))
Below is my code (I have 3 tabItems but am just focusing on getting the first tab: tabName = "2int" to work. Issue lies in the sever code of output$irr1. Can use the baseR cor() function in replace of agree() from the irr package for testing purposes. Just need the updated table to be saved as a dataframe with all numbers or matrix to function correctly with the agree() function.
library(shiny)
library(irr)
library(DT)
library(dplyr)
library(shinydashboard)
ui <- dashboardPage(
dashboardHeader(title = "Interview Reliability"),
dashboardSidebar(
sidebarMenu(
menuItem("Two Interviewers",
tabName = "2int",
icon = icon("glass-whiskey")),
menuItem("Three Interviewers",
tabName = "3int",
icon = icon("glass-whiskey")),
menuItem("Four Interviewers",
tabName = "4int",
icon = icon("glass-whiskey"))
)
),
dashboardBody(
tabItems(
tabItem(tabName = "2int",
fluidRow(box(sliderInput("obs1", "Number of Interview Questions:",
value = 4,
min = 4,
max = 12,
step = 1))),
box(dataTableOutput("table1")),
box(verbatimTextOutput("irr1")),
box(actionButton("calc1", "Calculate"))
),
tabItem(tabName = "3int",
box(sliderInput("obs2", "Number of Interview Questions:",
value = 4,
min = 4,
max = 12,
step = 1))
),
tabItem(tabName = "4int",
box(sliderInput("obs3", "Number of Interview Questions:",
value = 4,
min = 4,
max = 12,
step = 1)),
)
)
)
)
server <- function(input, output) {
tablevalues <- reactiveValues(df = NULL)
observeEvent(input$obs1, {
tablevalues$df <- matrix(NA, nrow = input$obs1, ncol = 2,
dimnames = list(1:input$obs1, c("Interviewer 1", "Interviewer 2")))
})
output$table1 <- renderDT(tablevalues$df, escape = FALSE, selection = 'none', editable=TRUE)
output$irr1 <- eventReactive(input$calc1, {
renderPrint(agree(as.data.frame(table1)))
})
}
shinyApp(ui = ui, server = server)
You are mixing things here, and therefore your syntax is incorrect. Try this
server <- function(input, output) {
tablevalues <- reactiveValues(df = NULL)
observeEvent(input$obs1, {
tablevalues$df <- matrix(NA, nrow = input$obs1, ncol = 2,
dimnames = list(1:input$obs1, c("Interviewer 1", "Interviewer 2")))
})
output$table1 <- renderDT(tablevalues$df, escape = FALSE, selection = 'none', editable=TRUE)
### update tablevalues$df with all the edits
observeEvent(input$table1_cell_edit,{
info = input$table1_cell_edit
str(info)
i = info$row
j = info$col
v = as.numeric(info$value) ### change it to info$value if your function does not need it to be numeric
tablevalues$df[i, j] <<- DT::coerceValue(v, tablevalues$df[i, j])
})
mycor <- eventReactive(input$calc1, {
cor(tablevalues$df)
})
output$irr1 <- renderPrint({mycor()})
}

R Shiny update textInput fields' in DT on changing variable selection

I am building an app where the user loads an .RData data set (the file can be downloaded from here) and selects variable from a list (DT), moves it to another list (also DT) and then the available factor levels are displayed in a third DT underneath. This third DT also has a column of dynamically generated textInput fields which match the number of available factor levels for the variable where the user can add new values for the existing factor levels. The entered values are stored in a reactiveValues object. For now the object is just printed in the R console. The app looks like this:
library(shiny)
library(DT)
library(data.table)
library(shinyFiles)
ui <- fluidPage(
shinyFilesButton(id = "recodeChooseSrcFile", label = "Choose data file", title = "Navigate and select a file", multiple = FALSE),
fluidRow(
column(width = 6,
DTOutput(outputId = "recodeAllAvailableVars"),
),
column(width = 1, align = "center",
br(), br(), br(), br(), br(), br(), br(), br(), br(), br(),
uiOutput(outputId = "recodeArrowSelVarsRight"),
br(), br(),
uiOutput(outputId = "recodeArrowSelVarsLeft"),
),
column(width = 5,
DTOutput(outputId = "recodeVarsSelection"),
),
br(), br()
),
br(), br(),
DTOutput(outputId = "recodeScheme")
)
server <- function(input, output, session) {
available.volumes <- getVolumes()()
file.var.recode <- reactiveValues(loaded = NULL, var.levels = NULL)
# Select file and extract the variables.
shinyFileChoose(input, "recodeChooseSrcFile", roots = available.volumes, filetype = list(RData = "RData"))
observeEvent(eventExpr = input$recodeChooseSrcFile, {
if(length(parseFilePaths(available.volumes, input$recodeChooseSrcFile)$datapath) > 0) {
file.var.recode$loaded <- get(load(parseFilePaths(available.volumes, input$recodeChooseSrcFile)$datapath))
file.var.recode$var.levels <- Filter(Negate(is.null), lapply(X = file.var.recode$loaded, FUN = function(i) {
if(is.null(attr(x = i, which = "levels"))) {
NULL
} else {
attr(x = i, which = "levels")
}
}))
file.var.recode$loaded <- data.table(Variables = names(file.var.recode$loaded),
order_col = 1:ncol(file.var.recode$loaded))
}
}, ignoreInit = TRUE)
observe({
var.props.initial.available.vars <- data.table(Variables = as.character(), order_col = as.numeric())
var.props.initial.selected.vars <- data.table(Variables = as.character(), order_col = as.numeric())
recodeAllVars <- reactiveValues(recodeAvailVars = var.props.initial.available.vars, recodeSelectedVars = var.props.initial.selected.vars)
# Observe if the file is loaded, and if yes, update the table of available variables.
observe({
if(!is.null(file.var.recode$loaded)) {
recodeAllVars$recodeAvailVars <- file.var.recode$loaded
}
})
# Render the arrow buttons for selecting the variables.
output$recodeArrowSelVarsRight <- renderUI({
if(is.null(file.var.recode$loaded)) {
return(NULL)
} else {
actionButton(inputId = "recodeArrowSelVarsRight", label = NULL, icon("angle-right"), width = "50px")
}
})
output$recodeArrowSelVarsLeft <- renderUI({
if(is.null(file.var.recode$loaded)) {
return(NULL)
} else {
actionButton(inputId = "recodeArrowSelVarsLeft", label = NULL, icon("angle-left"), width = "50px")
}
})
# Render the data table with the available variables.
output$recodeAllAvailableVars <- renderDT({
if(is.null(file.var.recode$loaded)) {
return(NULL)
} else {
setkeyv(x = recodeAllVars$recodeAvailVars, cols = "order_col")
}
},
caption = "Available variables",
rownames = FALSE,
colnames = c("Names", "sortingcol"),
options = list(
ordering = FALSE,
columnDefs = list(list(visible = FALSE, targets = 1))
))
# Render the table with the selected variables.
output$recodeVarsSelection <- renderDT({
if(is.null(file.var.recode$loaded)) {
return(NULL)
} else {
setkeyv(x = recodeAllVars$recodeSelectedVars, cols = "order_col")
}
},
caption = "Available variables",
rownames = FALSE,
colnames = c("Names", "sortingcol"),
options = list(
ordering = FALSE,
columnDefs = list(list(visible = FALSE, targets = 1))
))
# Observe the events of moving variables from available to selected.
observeEvent(input$recodeArrowSelVarsRight, {
req(input$recodeAllAvailableVars_rows_selected)
recodeAllVars$recodeSelectedVars <- rbind(isolate(recodeAllVars$recodeSelectedVars), recodeAllVars$recodeAvailVars[input$recodeAllAvailableVars_rows_selected, , drop = F])
recodeAllVars$recodeSelectedVars <- recodeAllVars$recodeSelectedVars[complete.cases(recodeAllVars$recodeSelectedVars[ , "Variables"]), , drop = FALSE]
recodeAllVars$recodeAvailVars <- isolate(recodeAllVars$recodeAvailVars[-input$recodeAllAvailableVars_rows_selected, , drop = F])
})
observeEvent(input$recodeArrowSelVarsLeft, {
req(input$recodeVarsSelection_rows_selected)
recodeAllVars$recodeAvailVars <- rbind(isolate(recodeAllVars$recodeAvailVars), recodeAllVars$recodeSelectedVars[input$recodeVarsSelection_rows_selected, , drop = F])
recodeAllVars$recodeAvailVars <- recodeAllVars$recodeAvailVars[complete.cases(recodeAllVars$recodeAvailVars[ , "Variables"]), , drop = FALSE]
recodeAllVars$recodeSelectedVars <- isolate(recodeAllVars$recodeSelectedVars[-input$recodeVarsSelection_rows_selected, , drop = F])
})
# Render the table with the text inputs.
initial.recode.new.values <- reactiveValues(values = NULL)
entered.new.values <- reactiveValues(values = NULL)
new.recoding.values <- reactiveValues(values = NULL)
shinyInput <- function(obj) {
tmp <- unlist(lapply(X = seq_along(obj), FUN = function(i) {
i <- paste0(textInput(inputId = paste0("numinp", i), label = NULL, value = NULL, width = "50px"))
}))
return(tmp)
}
shinyValue <- function(id, len) {
unlist(lapply(seq_len(len), function(i) {
input[[paste0(id, i)]]
}))
}
# Observe the changes in user selection and update the reactive values from above.
observe({
initial.recode.new.values$values <- unlist(unique(file.var.recode$var.levels[recodeAllVars$recodeSelectedVars[ , Variables]]))
entered.new.values$values <- data.table(
V1 = initial.recode.new.values$values,
V2 = initial.recode.new.values$values,
V3 = rep(x = "->", times = length(initial.recode.new.values$values)),
V4 = shinyInput(unlist(unique(file.var.recode$var.levels[recodeAllVars$recodeSelectedVars[ , Variables]])))
)
new.recoding.values$values <- shinyValue(id = "numinp", len = length(unlist(unique(file.var.recode$var.levels[recodeAllVars$recodeSelectedVars[ , Variables]]))))
})
# Render the table with available levels and empty input fields where the user can enter his desired new values.
output$recodeScheme <- renderDT({
if(!is.null(unlist(unique(file.var.recode$var.levels[recodeAllVars$recodeSelectedVars[ , Variables]])))) {
entered.new.values$values
} else {
return(NULL)
}
},
rownames = FALSE,
colnames = c("Available variable values", "Old", "->", "New"),
class = "cell-border stripe;compact cell-border;",
selection="none",
escape = FALSE,
options = list(
pageLength = 1500,
dom = 'BRrt',
rowCallback = JS("function(r,d) {$(r).attr('height', '40px')}"),
preDrawCallback = JS('function() { Shiny.unbindAll(this.api().table().node()); }'),
drawCallback = JS('function() { Shiny.bindAll(this.api().table().node()); } ')))
observe({
print(new.recoding.values$values)
})
})
}
shinyApp(ui, server)
It all works fine when the variable is selected, the newly entered values are immediately updated and shown in the console on every key stroke. However, if the user decides to remove the variable from the DT of selected ones, the new.recoding.values$values reactive value becomes immediately NULL (as intended), but when another variable is added to the DT of selected variables, the old values for the previous variable are immediately brought back and never get updated. In addition, if the new variable has more levels than the first entered, then the last is possible to update, but not the previous ones (try entering ASBG03, then replace it with ASBG04 to see what I mean).
I don't really understand why is this happening. What I tried so far is to explicitly set the new.recoding.values$values to NULL in:
1.The observer where it is generated, before the shinyValue function is ran.
2.In the observeEvent where the right arrow button is pressed, i.e.:
observeEvent(input$recodeArrowSelVarsLeft, {
req(input$recodeVarsSelection_rows_selected)
recodeAllVars$recodeAvailVars <- rbind(isolate(recodeAllVars$recodeAvailVars),
recodeAllVars$recodeSelectedVars[input$recodeVarsSelection_rows_selected, , drop = F])
recodeAllVars$recodeAvailVars <- recodeAllVars$recodeAvailVars[complete.cases(recodeAllVars$recodeAvailVars[ , "Variables"]), , drop = FALSE]
recodeAllVars$recodeSelectedVars <- isolate(recodeAllVars$recodeSelectedVars[-input$recodeVarsSelection_rows_selected, , drop = F])
new.recoding.values$values <- NULL
})
UPDATE:
3.Following Tonio Liebrand's advice, I tried to update the text inputs as follow (added just after rendering the last DT):
observe({
if(nrow(entered.new.values$values) == 0) {
lapply(seq_len(length(unlist(unique(file.var.recode$var.levels[recodeAllVars$recodeSelectedVars[ , Variables]])))), function(i) {
updateTextInput(session,
input[[paste0("numinp", i)]],
value = NULL,
label = NULL)
})
}
})
None of these helped. Every time I remove the variable selected at first, the new.recoding.values$values is printed as NULL in the console, but then adding another variable new.recoding.values$values suddenly recovers the first values entered first, like it still "remembers" the first input.
I don't really understand this behavior can someone help to overcome this, i.e. really update on variable change?
Because the textFields are created within the datatable, you need to unbind before you use the table again (updateTextInput doesn't work). Using the code from this answer, I added the JS script with the unbind function and the function is called in the observer for the left arrow. Then you get a working app:
library(shiny)
library(DT)
library(data.table)
library(shinyFiles)
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());
}
})")
)),
shinyFilesButton(id = "recodeChooseSrcFile", label = "Choose data file", title = "Navigate and select a file", multiple = FALSE),
fluidRow(
column(width = 6,
DTOutput(outputId = "recodeAllAvailableVars"),
),
column(width = 1, align = "center",
br(), br(), br(), br(), br(), br(), br(), br(), br(), br(),
uiOutput(outputId = "recodeArrowSelVarsRight"),
br(), br(),
uiOutput(outputId = "recodeArrowSelVarsLeft"),
),
column(width = 5,
DTOutput(outputId = "recodeVarsSelection"),
),
br(), br()
),
br(), br(),
DTOutput(outputId = "recodeScheme")
)
server <- function(input, output, session) {
available.volumes <- getVolumes()()
file.var.recode <- reactiveValues(loaded = NULL, var.levels = NULL)
# Select file and extract the variables.
shinyFileChoose(input, "recodeChooseSrcFile", roots = available.volumes, filetype = list(RData = "RData"))
observeEvent(eventExpr = input$recodeChooseSrcFile, {
if(length(parseFilePaths(available.volumes, input$recodeChooseSrcFile)$datapath) > 0) {
file.var.recode$loaded <- get(load(parseFilePaths(available.volumes, input$recodeChooseSrcFile)$datapath))
file.var.recode$var.levels <- Filter(Negate(is.null), lapply(X = file.var.recode$loaded, FUN = function(i) {
if(is.null(attr(x = i, which = "levels"))) {
NULL
} else {
attr(x = i, which = "levels")
}
}))
file.var.recode$loaded <- data.table(Variables = names(file.var.recode$loaded),
order_col = 1:ncol(file.var.recode$loaded))
}
}, ignoreInit = TRUE)
observe({
var.props.initial.available.vars <- data.table(Variables = as.character(), order_col = as.numeric())
var.props.initial.selected.vars <- data.table(Variables = as.character(), order_col = as.numeric())
recodeAllVars <- reactiveValues(recodeAvailVars = var.props.initial.available.vars, recodeSelectedVars = var.props.initial.selected.vars)
# Observe if the file is loaded, and if yes, update the table of available variables.
observe({
if(!is.null(file.var.recode$loaded)) {
recodeAllVars$recodeAvailVars <- file.var.recode$loaded
}
})
# Render the arrow buttons for selecting the variables.
output$recodeArrowSelVarsRight <- renderUI({
if(is.null(file.var.recode$loaded)) {
return(NULL)
} else {
actionButton(inputId = "recodeArrowSelVarsRight", label = NULL, icon("angle-right"), width = "50px")
}
})
output$recodeArrowSelVarsLeft <- renderUI({
if(is.null(file.var.recode$loaded)) {
return(NULL)
} else {
actionButton(inputId = "recodeArrowSelVarsLeft", label = NULL, icon("angle-left"), width = "50px")
}
})
# Render the data table with the available variables.
output$recodeAllAvailableVars <- renderDT({
if(is.null(file.var.recode$loaded)) {
return(NULL)
} else {
setkeyv(x = recodeAllVars$recodeAvailVars, cols = "order_col")
}
},
caption = "Available variables",
rownames = FALSE,
colnames = c("Names", "sortingcol"),
options = list(
ordering = FALSE,
columnDefs = list(list(visible = FALSE, targets = 1))
))
# Render the table with the selected variables.
output$recodeVarsSelection <- renderDT({
if(is.null(file.var.recode$loaded)) {
return(NULL)
} else {
setkeyv(x = recodeAllVars$recodeSelectedVars, cols = "order_col")
}
},
caption = "Available variables",
rownames = FALSE,
colnames = c("Names", "sortingcol"),
options = list(
ordering = FALSE,
columnDefs = list(list(visible = FALSE, targets = 1))
))
# Observe the events of moving variables from available to selected.
observeEvent(input$recodeArrowSelVarsRight, {
req(input$recodeAllAvailableVars_rows_selected)
recodeAllVars$recodeSelectedVars <- rbind(isolate(recodeAllVars$recodeSelectedVars), recodeAllVars$recodeAvailVars[input$recodeAllAvailableVars_rows_selected, , drop = F])
recodeAllVars$recodeSelectedVars <- recodeAllVars$recodeSelectedVars[complete.cases(recodeAllVars$recodeSelectedVars[ , "Variables"]), , drop = FALSE]
recodeAllVars$recodeAvailVars <- isolate(recodeAllVars$recodeAvailVars[-input$recodeAllAvailableVars_rows_selected, , drop = F])
})
observeEvent(input$recodeArrowSelVarsLeft, {
req(input$recodeVarsSelection_rows_selected)
recodeAllVars$recodeAvailVars <- rbind(isolate(recodeAllVars$recodeAvailVars), recodeAllVars$recodeSelectedVars[input$recodeVarsSelection_rows_selected, , drop = F])
recodeAllVars$recodeAvailVars <- recodeAllVars$recodeAvailVars[complete.cases(recodeAllVars$recodeAvailVars[ , "Variables"]), , drop = FALSE]
recodeAllVars$recodeSelectedVars <- isolate(recodeAllVars$recodeSelectedVars[-input$recodeVarsSelection_rows_selected, , drop = F])
session$sendCustomMessage("unbindDT", "recodeScheme")
})
# Render the table with the text inputs.
initial.recode.new.values <- reactiveValues(values = NULL)
entered.new.values <- reactiveValues(values = NULL)
new.recoding.values <- reactiveValues(values = NULL)
shinyInput <- function(obj) {
tmp <- unlist(lapply(X = seq_along(obj), FUN = function(i) {
i <- paste0(textInput(inputId = paste0("numinp", i), label = NULL, value = NULL, width = "50px"))
}))
return(tmp)
}
shinyValue <- function(id, len) {
unlist(lapply(seq_len(len), function(i) {
input[[paste0(id, i)]]
}))
}
# Observe the changes in user selection and update the reactive values from above.
observe({
initial.recode.new.values$values <- unlist(unique(file.var.recode$var.levels[recodeAllVars$recodeSelectedVars[ , Variables]]))
entered.new.values$values <- data.table(
V1 = initial.recode.new.values$values,
V2 = initial.recode.new.values$values,
V3 = rep(x = "->", times = length(initial.recode.new.values$values)),
V4 = shinyInput(unlist(unique(file.var.recode$var.levels[recodeAllVars$recodeSelectedVars[ , Variables]])))
)
new.recoding.values$values <- shinyValue(id = "numinp", len = length(unlist(unique(file.var.recode$var.levels[recodeAllVars$recodeSelectedVars[ , Variables]]))))
})
# Render the table with available levels and empty input fields where the user can enter his desired new values.
output$recodeScheme <- renderDT({
if(!is.null(unlist(unique(file.var.recode$var.levels[recodeAllVars$recodeSelectedVars[ , Variables]])))) {
entered.new.values$values
} else {
return(NULL)
}
},
rownames = FALSE,
colnames = c("Available variable values", "Old", "->", "New"),
class = "cell-border stripe;compact cell-border;",
selection="none",
escape = FALSE,
options = list(
pageLength = 1500,
dom = 'BRrt',
rowCallback = JS("function(r,d) {$(r).attr('height', '40px')}"),
preDrawCallback = JS('function() { Shiny.unbindAll(this.api().table().node()); }'),
drawCallback = JS('function() { Shiny.bindAll(this.api().table().node()); } ')))
observe({
print(new.recoding.values$values)
})
})
}
shinyApp(ui, server)
However, I recommend you to read more about reactivity, e.g. here. You use a lot of observers, and you nest them. I don't recommend that, because this can lead to strange behaviour. Also, try to use more reactive/reactiveExpression, because observe/observeEvent can make your app slower. Before I found the correct solution, I tried to unnest your code a bit, and it still works! That shows that you had complexity in your app you actually don't need:
library(shiny)
library(DT)
library(data.table)
library(shinyFiles)
# additional functions
shinyInput <- function(obj) {
tmp <- unlist(lapply(X = seq_along(obj), FUN = function(i) {
i <- paste0(textInput(inputId = paste0("numinp", i), label = NULL, value = NULL, width = "50px"))
}))
return(tmp)
}
shinyValue <- function(id, len, input) {
unlist(lapply(seq_len(len), function(i) {
input[[paste0(id, i)]]
}))
}
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());
}
})")
)),
shinyFilesButton(id = "recodeChooseSrcFile", label = "Choose data file", title = "Navigate and select a file", multiple = FALSE),
fluidRow(
column(width = 6,
DTOutput(outputId = "recodeAllAvailableVars"),
),
column(width = 1, align = "center",
br(), br(), br(), br(), br(), br(), br(), br(), br(), br(),
uiOutput(outputId = "recodeArrowSelVarsRight"),
br(), br(),
uiOutput(outputId = "recodeArrowSelVarsLeft"),
),
column(width = 5,
DTOutput(outputId = "recodeVarsSelection"),
),
br(), br()
),
br(), br(),
DTOutput(outputId = "recodeScheme")
)
server <- function(input, output, session) {
available.volumes <- getVolumes()()
file.var.recode <- reactiveValues(loaded = NULL, var.levels = NULL)
# define variables
# Render the table with the text inputs.
initial.recode.new.values <- reactiveValues(values = NULL)
entered.new.values <- reactiveValues(values = NULL)
new.recoding.values <- reactiveValues(values = NULL)
# Select file and extract the variables.
shinyFileChoose(input, "recodeChooseSrcFile", roots = available.volumes, filetype = list(RData = "RData"))
observeEvent(eventExpr = input$recodeChooseSrcFile, {
if(length(parseFilePaths(available.volumes, input$recodeChooseSrcFile)$datapath) > 0) {
file.var.recode$loaded <- get(load(parseFilePaths(available.volumes, input$recodeChooseSrcFile)$datapath))
file.var.recode$var.levels <- Filter(Negate(is.null), lapply(X = file.var.recode$loaded, FUN = function(i) {
if(is.null(attr(x = i, which = "levels"))) {
NULL
} else {
attr(x = i, which = "levels")
}
}))
file.var.recode$loaded <- data.table(Variables = names(file.var.recode$loaded),
order_col = 1:ncol(file.var.recode$loaded))
}
}, ignoreInit = TRUE)
recodeAllVars <- reactiveValues(recodeAvailVars = data.table(Variables = as.character(), order_col = as.numeric()),
recodeSelectedVars = data.table(Variables = as.character(), order_col = as.numeric()))
# Observe if the file is loaded, and if yes, update the table of available variables.
observe({
if(!is.null(file.var.recode$loaded)) {
recodeAllVars$recodeAvailVars <- file.var.recode$loaded
}
})
# Render the arrow buttons for selecting the variables.
output$recodeArrowSelVarsRight <- renderUI({
if(is.null(file.var.recode$loaded)) {
return(NULL)
} else {
actionButton(inputId = "recodeArrowSelVarsRight", label = NULL, icon("angle-right"), width = "50px")
}
})
output$recodeArrowSelVarsLeft <- renderUI({
if(is.null(file.var.recode$loaded)) {
return(NULL)
} else {
actionButton(inputId = "recodeArrowSelVarsLeft", label = NULL, icon("angle-left"), width = "50px")
}
})
# Render the data table with the available variables.
output$recodeAllAvailableVars <- renderDT({
if(is.null(file.var.recode$loaded)) {
return(NULL)
} else {
setkeyv(x = recodeAllVars$recodeAvailVars, cols = "order_col")
}
},
caption = "Available variables",
rownames = FALSE,
colnames = c("Names", "sortingcol"),
options = list(
ordering = FALSE,
columnDefs = list(list(visible = FALSE, targets = 1))
))
# Render the table with the selected variables.
output$recodeVarsSelection <- renderDT({
if(is.null(file.var.recode$loaded)) {
return(NULL)
} else {
setkeyv(x = recodeAllVars$recodeSelectedVars, cols = "order_col")
}
},
caption = "Available variables",
rownames = FALSE,
colnames = c("Names", "sortingcol"),
options = list(
ordering = FALSE,
columnDefs = list(list(visible = FALSE, targets = 1))
))
# Observe the events of moving variables from available to selected.
observeEvent(input$recodeArrowSelVarsRight, {
req(input$recodeAllAvailableVars_rows_selected)
recodeAllVars$recodeSelectedVars <- rbind(isolate(recodeAllVars$recodeSelectedVars), recodeAllVars$recodeAvailVars[input$recodeAllAvailableVars_rows_selected, , drop = F])
recodeAllVars$recodeSelectedVars <- recodeAllVars$recodeSelectedVars[complete.cases(recodeAllVars$recodeSelectedVars[ , "Variables"]), , drop = FALSE]
recodeAllVars$recodeAvailVars <- isolate(recodeAllVars$recodeAvailVars[-input$recodeAllAvailableVars_rows_selected, , drop = F])
})
observeEvent(input$recodeArrowSelVarsLeft, {
req(input$recodeVarsSelection_rows_selected)
recodeAllVars$recodeAvailVars <- rbind(isolate(recodeAllVars$recodeAvailVars), recodeAllVars$recodeSelectedVars[input$recodeVarsSelection_rows_selected, , drop = F])
recodeAllVars$recodeAvailVars <- recodeAllVars$recodeAvailVars[complete.cases(recodeAllVars$recodeAvailVars[ , "Variables"]), , drop = FALSE]
recodeAllVars$recodeSelectedVars <- isolate(recodeAllVars$recodeSelectedVars[-input$recodeVarsSelection_rows_selected, , drop = F])
session$sendCustomMessage("unbindDT", "recodeScheme")
})
# Observe the changes in user selection and update the reactive values from above.
observe({
initial.recode.new.values$values <- unlist(unique(file.var.recode$var.levels[recodeAllVars$recodeSelectedVars[ , Variables]]))
entered.new.values$values <- data.table(
V1 = initial.recode.new.values$values,
V2 = initial.recode.new.values$values,
V3 = rep(x = "->", times = length(initial.recode.new.values$values)),
V4 = shinyInput(unlist(unique(file.var.recode$var.levels[recodeAllVars$recodeSelectedVars[ , Variables]])))
)
new.recoding.values$values <- shinyValue(id = "numinp",
len = length(unlist(unique(file.var.recode$var.levels[recodeAllVars$recodeSelectedVars[ , Variables]]))),
input = input)
})
# Render the table with available levels and empty input fields where the user can enter his desired new values.
output$recodeScheme <- renderDT({
if(!is.null(unlist(unique(file.var.recode$var.levels[recodeAllVars$recodeSelectedVars[ , Variables]])))) {
entered.new.values$values
} else {
return(NULL)
}
},
rownames = FALSE,
colnames = c("Available variable values", "Old", "->", "New"),
class = "cell-border stripe;compact cell-border;",
selection="none",
escape = FALSE,
options = list(
pageLength = 1500,
dom = 'BRrt',
rowCallback = JS("function(r,d) {$(r).attr('height', '40px')}"),
preDrawCallback = JS('function() { Shiny.unbindAll(this.api().table().node()); }'),
drawCallback = JS('function() { Shiny.bindAll(this.api().table().node()); } ')))
observe({
print(new.recoding.values$values)
})
# end of server
}
shinyApp(ui, server)
There is still some room for improvement, e.g. you could try to use a reactive instead of observe for the following snippet:
# Observe if the file is loaded, and if yes, update the table of available variables.
observe({
if(!is.null(file.var.recode$loaded)) {
recodeAllVars$recodeAvailVars <- file.var.recode$loaded
}
})

R Shiny store the user input from multiple dynamically generated textAreaInput fields in an object in the server part

New to shiny and struggling with this for more than two days now.
I have created an application where the user loads .csv data file and chooses one or more variables whose names appear in the application as check boxes. When a checkbox is checked, a new checkbox appears under with the same name and when it is clicked too, a textAreaInput appears next to it where the user can add variable names that constitute the target variable as a scale. Here is an oversimplified version of the application:
library(shiny)
ui <- fluidPage(
mainPanel(
fileInput(inputId = "file", label = "Choose File", multiple = TRUE, accept = ".csv"),
uiOutput(outputId = "varCheckBoxesIndivScores"),
column(width = 3,
uiOutput(outputId = "selectedScoresCheckBoxes")),
conditionalPanel(condition = "input.selectedScoresCheckBoxes",
column(width = 6,
uiOutput(outputId = "variablesConstitutingScale"))
)
)
)
server = function(input, output, session) {
df <- reactive({
if(is.null(input$file)) {
return(NULL)
} else {
tbl <- fread(input$file$datapath, stringsAsFactors = TRUE)
return(tbl)
}
})
output$varCheckBoxesIndivScores <- renderUI({
if(is.null(df())) {
return(NULL)
} else if(!is.null(df())) {
return(tags$div(align = "left",
class = "multicol",
checkboxGroupInput(inputId = "varCheckBoxesIndivScores",
label = "Select variables",
choices = colnames(df()))))
}
})
output$selectedScoresCheckBoxes <- renderUI({
if(is.null(df())) {
return(NULL)
} else if(!is.null(df())) {
return(tags$div(align = "left",
checkboxGroupInput(inputId = "selectedScoresCheckBoxes",
label = "",
choices = input$varCheckBoxesIndivScores)))
}
})
output$variablesConstitutingScale <- renderUI({
if(is.null(df())) {
return(NULL)
} else if(!is.null(df()) & length(input$selectedScoresCheckBoxes > 0)) {
var.list.input.fields <- lapply(input$selectedScoresCheckBoxes, function(i) {
textAreaInput(inputId = "i", label = paste("Variables constituting scale", i), width = "700px", height = "100px", value = NULL)
})
var.list.input.fields
}
})
}
shinyApp(ui = ui, server = server)
The data to load is generated like this (just an excerpt, the real one has more columns and cases):
library(data.table)
x <- data.table(ID = c(2201:2220), VAR1 = rnorm(n = 20, mean = 10, sd = 2),
VAR2 = rnorm(n = 20, mean = 100, sd = 20), VAR3 = 1:20, VAR4 = 21:40,
VAR5 = 41:60, VAR6 = 61:80, VAR7 = 81:100)
write.csv(x = x, file = "/tmp/test_data.csv", row.names = FALSE)
It works fine, no errors. Here is how it looks, after I enter the variable names in each of the generated textAreaInput fields:
However, I would like to take the user input from each dynamically generated textAreaInput and store it in a list like:
list(VAR1 = "VAR3 VAR4 VAR5", VAR2 = "VAR6 VAR7")
or
list(VAR1 = "VAR3", "VAR4", "VAR5", VAR2 = "VAR6", "VAR7")
inside the server part of the application for future use.
I tried to follow the solution in this thread, but I did not succeed to come to any solution and feel quite confused. Can someone help?
First, you want to make sure to assign each of your dynimcally added elements to have a unique name. You have just hard coded the letter "i" in the sample. You want something like
textAreaInput(inputId = paste0("varconst_",i), label = paste("Variables constituting scale", i),
width = "700px", height = "100px", value = NULL)
Then you can observe those text boxes with something like this
observeEvent(lapply(paste0("varconst_", input$selectedScoresCheckBoxes), function(x) input[[x]]), {
obj <- Map(function(x) input[[paste0("varconst_",x)]], input$selectedScoresCheckBoxes)
dput(obj)
})
Here I just used dput to dump the list to the console so you can see it as it gets updated but you can do whatever you want with that.
I have modified the code of the application as per MrFlick's answer. To leave a paper trail of the complete solution, I am posting it below. The few additional modifications I have made include the printout of the list with the variables for each of the generated textAreaInput fields, so that the list can be viewed in the application itself. I have also added some further modifications of the obj, after it is generated, to obtain the list as desired.
If there are more dynamically generated output sections where check boxes and related text areas, the varconst_ index has to be made unique across the different chunks of code (e.g. varconst1_, varconst2_, varconst3_, etc.).
Here is the code:
library(shiny)
ui <- fluidPage(
mainPanel(
fileInput(inputId = "file", label = "Choose File", multiple = TRUE, accept = ".csv"),
uiOutput(outputId = "varCheckBoxesIndivScores"),
fluidRow(
column(width = 3,
uiOutput(outputId = "selectedScoresCheckBoxes")),
conditionalPanel(condition = "input.selectedScoresCheckBoxes",
column(width = 6,
uiOutput(outputId = "variablesConstitutingScale")))),
br(),
fluidRow(
conditionalPanel(condition = "input.selectedScoresCheckBoxes",
verbatimTextOutput(outputId = "scalesVarList")))
)
)
server = function(input, output, session) {
df <- reactive({
if(is.null(input$file)) {
return(NULL)
} else {
tbl <- fread(input$file$datapath, stringsAsFactors = TRUE)
return(tbl)
}
})
output$varCheckBoxesIndivScores <- renderUI({
if(is.null(df())) {
return(NULL)
} else if(!is.null(df())) {
return(tags$div(align = "left",
class = "multicol",
checkboxGroupInput(inputId = "varCheckBoxesIndivScores",
label = "Select variables",
choices = colnames(df()))))
}
})
output$selectedScoresCheckBoxes <- renderUI({
if(is.null(df())) {
return(NULL)
} else if(!is.null(df())) {
return(tags$div(align = "left",
checkboxGroupInput(inputId = "selectedScoresCheckBoxes",
label = "",
choices = input$varCheckBoxesIndivScores)))
}
})
output$variablesConstitutingScale <- renderUI({
if(is.null(df())) {
return(NULL)
} else if(!is.null(df()) & length(input$selectedScoresCheckBoxes > 0)) {
var.list.input.fields <- lapply(input$selectedScoresCheckBoxes, function(i) {
textAreaInput(inputId = paste0("varconst_",i), label = paste("Variables constituting scale", i),
width = "700px", height = "100px", value = NULL)
})
var.list.input.fields
}
})
observeEvent(lapply(paste0("varconst_", input$selectedScoresCheckBoxes), function(x) input[[x]]), {
obj <- Map(function(x) input[[paste0("varconst_",x)]], input$selectedScoresCheckBoxes)
obj <- sapply(obj, function(i) {
if(length(i) > 0) {
strsplit(x = i, split = " ")
}
})
dput(obj)
output$scalesVarList <- renderPrint({
if(is.null(df())) {
return(NULL)
} else if(!is.null(df()) && length(input$selectedScoresCheckBoxes) > 0 && length(obj) > 0) {
print(obj)
}
})
})
}
shinyApp(ui = ui, server = server)

Wrapping shiny modules in R6 classes

I am currently wrapping shiny modules in R6 classes and wanted to hear some opinions about this design.
Basically, I am interested in a clean approach (readable code) and want the classes to allow nesting (see the nesting modules section here). The current code fulfills both criteria but I have some questions regarding the details of the implementation (See "Questions" below).
Context
I am writing polymorphic modules and figured R6 is a good way to inherit certain behaviors between modules. The objects created share data across sessions (not included in the example below), so I constructed them in global.R.
Class code
MyModule <- R6Class(
public = list(
initialize = function(id = shiny:::createUniqueId()){
private$id <- id
},
bind = function(){
callModule(private$module_server, private$id)
},
ui = function(ns = NS(NULL)){
ns <- NS(ns(private$id))
fluidPage(
textInput(ns("text_in"), "text", "enter some text"),
textOutput(ns("text_out"))
)
}
),
private = list(
id = NULL,
module_server = function(input, output, session){
ns <- session$ns
output$text_out <- renderText({
input$text_in
})
}
)
)
Simple usage
myObj <- MyModule$new()
shinyApp(
myObj$ui(),
function(input, output, session){ myObj$bind() }
)
Nesting
some_other_module <- function(input, output, session, obj){
obj$bind()
ns <- session$ns
output$obj_ui <- renderUI({
obj$ui(ns)
})
}
some_other_moduleUI <- function(id){
ns <- NS(id)
uiOutput(ns("obj_ui"))
}
shinyApp(
some_other_moduleUI("some_id"),
function(input, output, session){
callModule(some_other_module, "some_id", myObj)
}
)
Questions
Has anyone done something similar before? If so, where are the main differences to my approach?
Is it safe to use shiny:::createUniqueId()? If not, is there a similar function available in the base package? I really want to limit the dependencies for the package I am developing.
I have been warned about using wrappers around callModule because of nesting. Can anyone show a use/case where this approach fails?
Would it be better to use a static function (rather than a member function) to build the ui code?
Thanks in advance for any inputs about this topic!
I know this is a really old post, but I wanted to post here because I really like the approach. I read this post a few months ago, and since then have applied it in a few cases, and I think more are coming. While shiny modules are great, wrapping shiny modules in R6 objects is another step up in organizing code. When applications become very large, it is highly advantageous to minimize the code in the ui and server functions, and instead call methods of well-defined R6 objects.
One thing I found to be really useful is that an R6 object as defined in the OP can include both multiple UI methods, and multiple server methods. This way different UI elements that "belong together" can be seen as methods of the same object. Each of the UI elements can have its own server function (or no server function).
To demonstrate look at the example below. Mind you: this particular example can be achieved with much less code, but the real purpose is to call simple methods in the main UI and server functions of the shiny app. This makes the logic there really obvious, and saves a lot of time duplicating parts of an application etc.
The example below makes an R6 object with UI methods for an input section (choosing columns of a dataset), and a reactive plot method (using those columns). All data is stored inside the object, so there is no need to pass things around in your server function. We end up with a very, very short shiny app (once the object is defined).
The OP used a single bind method that runs the single server function. Here, we have two server functions, each defined as a clear method of our object. With two UI functions, we also need to generate two IDs. Otherwise the approach is as the OP.
library(shiny)
library(R6)
library(uuid)
library(ggplot2)
# Define an R6 object.
bivariateClass <- R6Class(
public = list(
id_input = NULL,
id_plot = NULL,
data = NULL,
columns = NULL,
settings = reactiveValues(),
initialize = function(data){
# Assign random IDs for both UI methods.
self$id_input <- uuid::UUIDgenerate()
self$id_plot <- uuid::UUIDgenerate()
self$data <- data
self$columns <- names(data)
},
# UI function for input fields (choosing columns from the data)
ui_input = function(ns = NS(NULL)){
ns <- NS(ns(self$id_input))
tagList(
selectInput(ns("txt_xvar"), "X variable", choices = self$columns),
selectInput(ns("txt_yvar"), "Y variable", choices = self$columns),
actionButton(ns("btn_save_vars"), "Save", icon = icon("save"))
)
},
# UI function for the plot output
ui_plot = function(ns = NS(NULL)){
ns <- NS(ns(self$id_plot))
plotOutput(ns("plot_main"))
},
# Call the server function for saving chosen variables
store_variables = function(){
callModule(private$store_server, id = self$id_input)
},
# Call the server function for rendering the plot
render_plot = function(){
callModule(private$plot_server, id = self$id_plot)
}
),
private = list(
# Server function for column selection
# This way, input data can be collected in a neat way,
# and stored inside our object.
store_server = function(input, output, session){
observeEvent(input$btn_save_vars, {
self$settings$xvar <- input$txt_xvar
self$settings$yvar <- input$txt_yvar
})
},
# Server function for making the plot
plot_server = function(input, output, session){
output$plot_main <- renderPlot({
req(self$settings$xvar)
req(self$settings$yvar)
x <- self$settings$xvar
y <- self$settings$yvar
ggplot(self$data, aes(!!sym(x), !!sym(y))) +
geom_point()
})
}
)
)
# Make a new object, only here do we have to pass a data object.
# This makes it easy to manage many objects, with different settings.
xy_mtcars <- bivariateClass$new(data = mtcars)
# UI
# Here we only have to call the UI methods.
ui <- fluidPage(
xy_mtcars$ui_input(),
tags$hr(),
xy_mtcars$ui_plot()
)
# And here we just have to call the server methods.
server <- function(input, output, session) {
xy_mtcars$store_variables()
xy_mtcars$render_plot()
}
shinyApp(ui, server)
I am beginner in R6 and OOP.
Here is a reprex that I've done in classic Shiny code calling R6 modules in two panels.
It's inspired by :
march 25, 2019, zhuchcn.github.io: Modularize your shiny app using shiny module and R6 class, written by Chenghao Zhu, but in his case the code is 100% OOP i.e. also in ui et server. In my case it's for reusability in my project in classic Shiny code.
July 20, 2018, tbradley1013.github.io: Using global input values inside of R Shiny modules, written by Tyler Bradley, where he made a demonstration to use reactive(myreactive()) in the call of modules.
For the two last questions:
3 : I think there is not issue about nested module, in my example at least. If I understood the question.
4 : I've looking for static function at the beginning for UI side, because of the instanciation too late in the server side. But except the root of my UIs R6 class, which could be in static or not in R6, all of my UIs R6 are in fact in the server side.
code updated : observeEvent(..[R6 module called]..., once=TRUE) added, bugs fixed, hidden textInput() removed
Look at https://github.com/philibe/RShinyR6POC for the source code detail.
Code abstract
Modules_R6_Examples.R
# called in UI
FicheTabGraphUI = R6Class(
"FicheTabGraphUI",
public = list(
FicheTabGraphUI_UI= function (prefixe){
ns<-NS(prefixe)
tagList(
uiOutput(ns("FicheTabGraphUI_UI"))
)
}
)
)
# called in SERVER
FicheTabGraph = R6Class(
"FicheTabGraph",
public = list(
id = NULL,
ns =NULL,
ListeTitres=NULL,
ListeIdGraphs=NULL,
DetailsTableIn=NULL,
RapportCourant.react=NULL,
DetailsTableInFormatOutput.Fct=NULL ,
# initializer
initialize = function(input,output, session,id,ListeTitres,ListeIdGraphs,DetailsTableIn,
DetailsTableInFormatOutput.Fct =NULL){
self$id = id
self$ns = NS(id)
self$SetListeTitres(ListeTitres)
self$SetListeIdGraphs(ListeIdGraphs)
self$DetailsTableInFormatOutput.Fct=function (mydatatable) {DT::datatable( mydatatable)}
callModule(private$FicheTabGraphSERVER,self$id )
private$server(input, output, session, DetailsTableIn,DetailsTableInFormatOutput.Fct)
},
SetListeTitres=function (ListeTitres){
self$ListeTitres= ListeTitres
},
SetListeIdGraphs=function (ListeIdGraphs){
self$ListeIdGraphs= ListeIdGraphs
},
FicheTabGraph_renderUI= function (ListeTitres=self$ListeTitres){
tagList(
fluidRow(
h4(ListeTitres[[1]]),
column (12,
div(
DT::dataTableOutput(self$ns("FichePrixTableUI")),
class="data_table_output"
)
)
),
fluidRow(
h4(ListeTitres[[2]]),
column (12,
div(
self$FichePrixPlotUI_UI()
)
)
)
)
},
FichePrixPlotUI_UI = function(ListeIdGraphs= self$ListeIdGraphs){
divGraphs <- div()
for (num in 1:length(ListeIdGraphs)) {
divGraphs <- tagAppendChild(divGraphs, column (6,plotOutput(self$ns(ListeIdGraphs[[num]]))))
}
tagList(
divGraphs
)
}
),
private = list(
SetDetailsTableIn = function(DetailsTableIn ) {
self$DetailsTableIn<-DetailsTableIn
},
DetailsTableSERVER = function(input, output, session ) {
output$FichePrixTableUI <- DT::renderDataTable(self$DetailsTableInFormatOutput.Fct(self$DetailsTableIn())
)
},
SetDetailsTableInFormatOutput.Fct= function(DetailsTableInFormatOutput.Fct=NULL ) {
if (!is.null(DetailsTableInFormatOutput.Fct)) {
self$DetailsTableInFormatOutput.Fct<-DetailsTableInFormatOutput.Fct
}
},
FicheTabGraphSERVER = function(input, output, session) {
output$FicheTabGraphUI_UI<- renderUI(self$FicheTabGraph_renderUI( ))
},
server= function(input, output, session, DetailsTableIn,
DetailsTableInFormatOutput.Fct =NULL){
private$SetDetailsTableIn(DetailsTableIn)
private$SetDetailsTableInFormatOutput.Fct(DetailsTableInFormatOutput.Fct)
callModule(private$DetailsTableSERVER, self$id )
}
)
)
# called in SERVER
FicheGraph = R6Class(
"FicheGraph",
public = list(
id = NULL,
ns =NULL,
DetailsTableIn=NULL,
# initializer
initialize = function(input,output, session,id,DetailsTableIn,
RatioTable.Fct,RatioPlot.Fct,cible
){
self$id = id
self$ns = NS(id)
self$SetDetailsTableIn(DetailsTableIn)
callModule(private$RatioPlotSERVER, self$id,self$DetailsTableIn, RatioTable.Fct,RatioPlot.Fct,cible )
},
SetDetailsTableIn = function(DetailsTableIn ) {
if (missing(DetailsTableIn)) return(self$DetailsTableIn)
self$DetailsTableIn<-DetailsTableIn
},
server= function(input, output, session,DetailsTableIn=self$DetailsTableIn,
RatioTable.Fct,RatioPlot.Fct,cible ) {
callModule(private$RatioPlotSERVER, self$id,DetailsTableIn, RatioTable.Fct,RatioPlot.Fct,cible )
}),
private= list(
RatioPlotSERVER = function(input, output, session,
DetailsTableIn,RatioTable.Fct,RatioPlot.Fct,cible ) {
output[[cible]] <- renderPlot(RatioPlot.Fct( RatioTable.Fct(DetailsTableIn())))
}
)
)
# called in UI
MiniRapportTabDynUI = R6Class(
"MiniRapportTabDynUI",
public = list(
MiniRapportTabDynUI_UI= function (prefixe, tagParamFiltre){
ns<-NS(prefixe)
tagList(
uiOutput(ns("MiniRapportTabDynUI_UI"))
)
}
)
)
# called in SERVER
MiniRapportTabDyn = R6Class(
"MiniRapportTabDyn",
public = list(
id = NULL,
ns =NULL,
ConsolidationFormatOutput.Fct=NULL,
DetailsTable=NULL,
RapportsList=NULL,
RapportCourant.react=NULL,
liste_colonnes_choisies.react=NULL,
reactValues=NULL,
# initializer
initialize = function(input, output, session,id, tagParamFiltre=div()){
self$id = id
self$ns = NS(id)
callModule(self$MiniRapportTabDynSERVER, self$id, tagParamFiltre )
self$ConsolidationFormatOutput.Fct=function (mydatatable) {DT::datatable( mydatatable)}
},
MiniRapportTabDyn_renderUI= function (tagParamFiltre=div()){
tagList(
fluidRow(
fluidRow(div(bsCollapsePanel_panneau_masquable.fct("Click on column name (are excluded columns whith calc, qte, num )",
div(
p("Click on column name (are excluded columns whith calc, qte, num )"),
column (12,
div(
uiOutput(self$ns("ChoixDimRegroupUI"))
#, style=""
)
)
)
), style="margin-left: 20px;"))
),
fluidRow(
column (12,
uiOutput(self$ns("ChoixDimRegroupChoisiUI"))
)
),
tagParamFiltre,
fluidRow(
column (12,
div(
div(uiOutput(self$ns("ChoixRapportUI")),
class='label_non_fixe_items_fixes'
)
)
) ,
column (12,
div( DT::dataTableOutput(self$ns("ConsolidationDataTableUI")),
class="data_table_output")
)
)
)
},
MiniRapportTabDynSERVER = function(input, output, session, tagParamFiltre = div()) {
output$MiniRapportTabDynUI_UI<- renderUI(self$MiniRapportTabDyn_renderUI(tagParamFiltre ))
},
server= function(input, output, session, MaitreTable_rows_selected,DetailsTable,RapportsList,
ConsolidationFormatOutput.Fct = NULL ){
private$SetDetailsTable(DetailsTable)
private$SetRapportsList( RapportsList)
callModule(private$ChoixDimRegroupSERVER, self$id, MaitreTable_rows_selected)
callModule(private$ChoixRapportSERVER, self$id )
callModule(private$ChoixDimRegroupChoisiSERVER, self$id )
private$SetConsolidationFormatOutput.Fct(ConsolidationFormatOutput.Fct)
callModule(private$ConsolidationDataTableSERVER, self$id )
}
),
private = list(
ListeColonnesDuChoixRapports.fct=function (DetailsTable = self$DetailsTable) {
list_colonnes=names(DetailsTable() )
list_colonnes<-list_colonnes[!grepl("calc|qte|num",list_colonnes)]
list_colonnes<-list_colonnes[order(list_colonnes)]
list_colonnes
},
RapportCourant.fct=function(input_choix_rapport, ListeRapportsDf=private$ListeRapportsDf()){
selection<-((ListeRapportsDf
# attention le Coalesce est avec un 1, comme rapport 1
%>% filter (value==DescTools::Coalesce(input_choix_rapport,1))
%>% select (choix_dim_regroup)
)[[1]]
)
selection <- str_split(selection,",")[[1]]
selection
},
checkboxGroupInput_renderUI= function (input_maitre_rows_selected,
ListeColonnesDuChoixRapports=private$ListeColonnesDuChoixRapports.fct(),
ElementsCoches = self$liste_colonnes_choisies.react()
)
{
#print(input_maitre_rows_selected)
if (DescTools::Coalesce(input_maitre_rows_selected,0)!=0) {
checkboxGroupInput(self$ns("ChoixDimRegroup"),
label = "",
choices = ListeColonnesDuChoixRapports,
inline = TRUE,
selected = ElementsCoches
)
}else return()
},
ChoixDimRegroupSERVER = function(input, output, session,
input_maitre_rows_selected
) {
self$reactValues<-reactiveValues(choix="RapportCourant")
self$RapportCourant.react<-reactive({
private$RapportCourant.fct(input$ChoixRapport)
})
observeEvent(input$ChoixDimRegroup,
self$reactValues$choix<-"ChoixDimRegroup"
)
observeEvent(input$ChoixRapport,
self$reactValues$choix<-"RapportCourant"
)
self$liste_colonnes_choisies.react<-reactive(private$liste_colonnes_choisies.fct(input$ChoixDimRegroup, RapportCourant=self$RapportCourant.react()))
output$ChoixDimRegroupUI <- renderUI(private$checkboxGroupInput_renderUI(input_maitre_rows_selected() ))
},
ListeRapportsDf=function (RapportsList=self$RapportsList) {
setNames(
data.frame(
t(data.frame(
RapportsList
))
,row.names = NULL,stringsAsFactors = FALSE
),
c("value","label","choix_dim_regroup")
)
},
ListeRapportsSetNames=function (ListeRapportsDf= private$ListeRapportsDf()) {
list_label_value <- ListeRapportsDf
setNames(list_label_value$value,list_label_value$label)
},
selectizeInput_create_renderUI =function(ListeRapportsSetNames=private$ListeRapportsSetNames()) {
selectizeInput(self$ns( "ChoixRapport"),
label="Report Choice",
choices =ListeRapportsSetNames,
width = '500px',
selected = "1"
# , options = list(render = I(''))
)
},
RapportChoisi_renderUI =function(list_colonnes) {
paste(unlist(list_colonnes),collapse=', ')
},
liste_colonnes_choisies.fct=function(input_ChoixDimRegroup,
RapportCourant,
Choix =self$reactValues$choix
) {
list_colonnes<-switch (Choix,
"ChoixDimRegroup"= input_ChoixDimRegroup,
"RapportCourant"= RapportCourant,
RapportCourant
)
list_colonnes
},
ConsolidationDataTable_renderDT=function(list_colonnes,
DetailsTable=self$DetailsTable,
ConsolidationFormatOutput.Fct=self$ConsolidationFormatOutput.Fct){
res<-NULL
res<- DetailsTable()
if (!is.null(res)) {
res2 <- (res
%>% group_by_at(., .vars = (intersect(list_colonnes,colnames(res))))
%>% summarise_at(vars(contains("calc", ignore.case = TRUE)),~sum(., na.rm = TRUE))
)
res_datas<-res2
}else {
res_datas<-data.frame(stringsAsFactors = FALSE)
}
ConsolidationFormatOutput.Fct(res_datas)
},
ChoixRapportSERVER = function(input, output, session ) {
output$ChoixRapportUI <- renderUI(private$selectizeInput_create_renderUI())
},
ChoixDimRegroupChoisiSERVER = function(input, output, session ) {
output$ChoixDimRegroupChoisiUI <- renderUI(private$RapportChoisi_renderUI(
self$liste_colonnes_choisies.react()
))
},
ConsolidationDataTableSERVER = function(input, output, session ) {
output$ConsolidationDataTableUI <- DT::renderDataTable(private$ConsolidationDataTable_renderDT(
self$liste_colonnes_choisies.react()
))
},
SetDetailsTable = function(DetailsTable ) {
self$DetailsTable<-DetailsTable
},
SetRapportsList = function(RapportsList ) {
RapportsList<-lapply(RapportsList, function (x,p,r) {
# To delete spaces from 3rd item
x[3]<-str_replace_all(x[3],p,r);
x
}," ","")
self$RapportsList<-RapportsList
},
SetConsolidationFormatOutput.Fct = function(ConsolidationFormatOutput.Fct=NULL ) {
if (!is.null(ConsolidationFormatOutput.Fct)) {
self$ConsolidationFormatOutput.Fct<-ConsolidationFormatOutput.Fct
}
}
)
)
app.R
options(encoding = "UTF-8")
library(shiny)
library(shinyjs)
library(shinyBS)
library(dplyr)
library(tidyr)
library(DT)
library(DescTools)
library(R6)
library(ggplot2)
library(ggforce)
library(cowplot)
library(stringr)
source("Modules_R6_Examples.R")
source("Others_Functions.R")
SERVER <- function(input, output, session) {
FakeDatas <- reactive({
vector_calc<- c("disp","hp","drat","wt","qsec")
(mtcars
%>% mutate(rowname=rownames(.),
TR=ifelse(cyl!=6,"NORM","TR")
)
%>% separate(rowname,c("marque","modele"), sep=" ", fill="right", extra="merge")
%>% rename_at(vars(vector_calc),list(calc=~paste0(.,"_calc")) )
%>% select (marque, modele,everything())
%>% select_at(vars(-contains("calc"),contains("calc")))
)
}
)
DetailsTable <- reactive({
input_appelant= input$MaitreTable_rows_selected
validate(
need(!is.null(input_appelant) , "select a line above (for example : Merc")
)
res<- data.frame(stringsAsFactors = FALSE)
isolate(FakeDatas())%>% filter (marque==isolate(MaitreTable())[as.integer(input_appelant), ])
})
consolidationDatas <- reactive({
res<-DetailsTable()
if ( DescTools::Coalesce(input$CheckbFilter,FALSE)==FALSE) {
res<-(res %>% filter (is.na(TR) | TR=="NORM")
)
}
if (nrow(res)>0) {
return(res)
} else {
return( res [FALSE,])
}
})
DetailsTable_filled<-reactive ({
if (
DescTools::Coalesce(nrow(DetailsTable()),0)>0
) TRUE else NULL
})
observeEvent(DetailsTable_filled(),
{
FirstExample<-MiniRapportTabDyn$new(input, output, session,"FirstExample",
div(
fluidRow(
column (3,
div(
p(checkboxInput("CheckbFilter",
"checked: take the TR",
FALSE,
width="100%"
))
)
)
)
)
)
FirstExample$server(input, output, session,
reactive(input$MaitreTable_rows_selected),
reactive(consolidationDatas()) ,
list( c(1,"basic report (marque)","marque"),
c(2,"other report (marque,model)","marque,modele")),
Global.detail.synthese.table.output.fct
)
}
,ignoreNULL = TRUE ,once=TRUE
)
observeEvent(input$tabs,
{
if (input$tabs=="2") {
FicheTabGraph$new(input, output, session,"SecondExample",
list("datas","graphs"),
list("RatioPlotUI","RepartitionCoutPlotUI"),
reactive(DonneesPie()),
DetailsTableInFormatOutput.Fct=Global.Fiche.output.fct
)
FicheGraph1<-FicheGraph$new(input, output, session,"SecondExample",reactive(DonneesPie()),
pie_plot_table.fct,
pie_plot_plot.fct,
cible="RatioPlotUI"
)
FicheGraph1
FicheGraph2<-FicheGraph1$clone(deep=TRUE)
FicheGraph2$server(input, output, session,
RatioTable.Fct=pie_plot_table.fct,
RatioPlot.Fct=pie_doubleplot_plot.fct,
cible="RepartitionCoutPlotUI"
)
}
}
,ignoreInit=TRUE,once=TRUE
)
MaitreTable <- reactive({
unique(isolate(FakeDatas()) %>% select(marque)%>% arrange(marque))
})
output$MaitreTable <- DT::renderDataTable(
DT::datatable( MaitreTable(),
style = "bootstrap", class = "compact", filter='top',
selection = c("single"),
options = list(
deferRender = TRUE,
bSortClasses = TRUE,iDisplayLength = 3, width = "100%",
scrollX=TRUE,
autoWidth = TRUE
)
)
)
output$DetailsTable <- DT::renderDataTable(
DT::datatable( DetailsTable() ,
style = "bootstrap", class = "compact", filter='top',
selection = c("single"),
options = list(
deferRender = TRUE,
bSortClasses = TRUE,iDisplayLength = 3, width = "100%",
scrollX=TRUE,
autoWidth = TRUE
)
)
)
}
BaseMiniRapportTabDynUI<-MiniRapportTabDynUI$new()
BaseFicheTabGraphUI<-FicheTabGraphUI$new()
largeur_page_pct<-96
UI<-shinyUI(
fluidPage(
useShinyjs(),
tags$style(type = "text/css", HTML(paste0(".data_table_output {font-size:80%;white-space: nowrap;width:",largeur_page_pct,"%;}"))),
tags$style(type = "text/css", HTML(paste0("
.bsCollapsePanel-petite {width:",largeur_page_pct,"%;
-webkit-transition-delay: 0s;
transition-delay: 0s;
margin-bottom: -20px;
}","
.bsCollapsePanel-petite .panel-body { padding: 0px;}
.bsCollapsePanel-petite .panel-title {font-size:80%;}
.bsCollapsePanel-petite .panel-heading {padding: 0px;}
"))),
tabsetPanel(id = "tabs",
tabPanel("First Example", value="1",
h1("First Example"),
DT::dataTableOutput('MaitreTable'),
fluidRow(
h2("select a line above to have mini report below "),p("for example 'Merc'")
),
fluidRow(
BaseMiniRapportTabDynUI$MiniRapportTabDynUI_UI("FirstExample")
),
fluidRow(
h4("Details"),
column (12,
div(DT::dataTableOutput('DetailsTable'),
class="data_table_output")
)
)),
tabPanel("Second Example",value="2",
fluidRow(
div(
BaseFicheTabGraphUI$FicheTabGraphUI_UI("SecondExample"),
style="margin-left: 20px;"
)
)
)
)
)
)
shinyApp(UI, SERVER)
Others_Functions.R
formatRound.try.fct <- function(mydatatable, mycolumn, taille) {
tryCatch({
return(DT::formatRound(mydatatable, mycolumn, taille))
}, error = function(cond) {
print(paste0("Warning: Erreur de nom de colonne (", mycolumn, ") pour formatRound"))
return(mydatatable)
})
}
Global.Fiche.output.fct <- function (mydatatable) {
res<-DT::datatable( mydatatable,
style = "bootstrap", class = "compact", filter='top',
selection = c("none"),
options = list(
deferRender = TRUE, bSortClasses = TRUE,iDisplayLength = 30, width = "100%",
scrollX=TRUE, autoWidth = TRUE
)
)
return (res)
}
Global.detail.synthese.table.output.fct <- function (mydatatable) {
res<-DT::datatable( mydatatable,
style = "bootstrap", class = "compact", filter='top',
selection = c("single"),
options = list(
deferRender = TRUE, bSortClasses = TRUE,iDisplayLength = 30, width = "100%",
scrollX=TRUE, autoWidth = TRUE
)
)
res <- (res
%>% formatRound.try.fct('disp_calc', 2)
%>% formatRound.try.fct('hp_calc', 2)
%>% formatRound.try.fct('drat_calc', 2)
)
return (res)
}
DonneesPie<- reactive(
data.frame(
state = c('eaten', 'eaten but said you didn\'t', 'cat took it',
'for tonight', 'will decompose slowly'),
focus = c(0.2, 0, 0, 0, 0),
start = c(0, 1, 2, 3, 4),
end = c(1, 2, 3, 4, 2*pi),
amount = c(4,3, 1, 1.5, 6),
coul=c(1,"aa","aa","bb","bb"),
stringsAsFactors = FALSE
)
)
pie_plot_table.fct=function (pie) {
pie %>%
mutate(end=2*pi*cumsum(amount)/sum(amount),
start = lag(end, default = 0),
middle = 0.5 * (start + end),
hjust = ifelse(middle > pi, 1, 0),
vjust = ifelse(middle < pi/2 | middle > 3 * pi/2, 0, 1),
label=paste(state, paste0(round(((amount/sum(amount))*100),2),"%;",amount,"euros"))
)
}
pie_plot_plot.fct=function(pie){
ggplot(pie) +
geom_arc_bar(aes(x0 = 0, y0 = 0, r0 = 0, r = 1,amount = amount,
fill = label,explode = focus),stat = 'pie') +
ggtitle("Plot of length by dose") +
labs(fill = "Dose (mg)")+
geom_text(aes(x = 1.05 * sin(middle), y = 1.05 * cos(middle),
label = label, hjust = hjust, vjust = vjust
)) +
coord_fixed() +theme_no_axes() +
scale_x_continuous(limits = c(-2, 2), name = "", breaks = NULL, labels = NULL) +
scale_y_continuous(limits = c(-1.5, 1.5), name = "", breaks = NULL, labels = NULL)
}
pie_doubleplot_plot.fct=function(mydata){
mydata<-mydata
p0<-ggplot(mydata)+ ggtitle("Plot of length by dose") +
coord_fixed() +theme_no_axes() +
scale_x_continuous(limits = c(-2, 2), # Adjust so labels are not cut off
name = "", breaks = NULL, labels = NULL) +
scale_y_continuous(limits = c(-1.5, 1.5), # Adjust so labels are not cut off
name = "", breaks = NULL, labels = NULL)
toto<-unlist(list(colorspace::qualitative_hcl(length(mydata$coul),"Dynamic"),
colorspace::qualitative_hcl(length(mydata$label),"Dark 3")))
titi<-setNames(toto,unlist(list(mydata$coul,mydata$label)))
p1<-p0 +
geom_arc_bar(aes(x0 = 0, y0 = 0, r0 = 0.6, r = 1,amount = amount,
fill = label,explode = focus),stat = 'pie') +
labs(fill = "ratio") +scale_fill_manual(values =titi)
p2<-p0+
geom_arc_bar(aes(x0 = 0, y0 = 0, r0 = 0, r = 0.5,amount = amount,
fill = coul,explode = focus),stat = 'pie',data=mydata) +
labs(fill = "produit")+ scale_fill_manual(values =titi)
ptotal<-p0 +
geom_arc_bar(aes(x0 = 0, y0 = 0, r0 = 0, r = 0.5,amount = amount,
fill = coul,explode = focus),stat = 'pie',data=mydata) +
geom_arc_bar(aes(x0 = 0, y0 = 0, r0 = 0.6, r = 1,amount = amount,
fill = label,explode = focus),stat = 'pie',data=mydata) +
scale_fill_manual(values = titi)+geom_text(aes(x = 1.05 * sin(middle), y = 1.05 * cos(middle),
label = label, hjust = hjust, vjust = vjust
))
plot_grid(ptotal+ theme(legend.position = "none"),
plot_grid(
get_legend(p1 + theme(legend.position = "right",plot.margin = unit(c(0,0,0,0), "cm"))),
NULL,
get_legend(p2 + theme(legend.position = "bottom",plot.margin = unit(c(0,0,0,0), "cm"))),
rel_heights = c(1, -0.7, 1), ncol=1
)
)
}
bsCollapsePanel_panneau_masquable.fct<- function (titre,contenu) {
div(shinyBS::bsCollapsePanel(titre,"",
contenu
),class="bsCollapsePanel-petite")
}

Resources