Wrapping shiny modules in R6 classes - r

Question

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!

Answer 1

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)

Answer 2

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")
}