23

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

  1. Has anyone done something similar before? If so, where are the main differences to my approach?
  2. 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.
  3. I have been warned about using wrappers around callModule because of nesting. Can anyone show a use/case where this approach fails?
  4. 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!

Lasarus9
  • 83
  • 9
Gregor de Cillia
  • 7,397
  • 1
  • 26
  • 43
  • 2
    To answer question 2: I don't see any problem with using shiny's ID generator, but there is also a specific package for that: `uuid` – DeanAttali Jan 11 '19 at 08:14
  • Thank you. The reason I was asking is that the function is not exported and `devtools::check()` likes to complain about that. :) – Gregor de Cillia Jan 11 '19 at 08:22
  • @Gregor de Cillia:My app is becoming very very big in ~2 files (one for Shiny, the other mainly for data processing). I am looking for a solution without use module directly . And I found your SO question (oct 11, 2017) and this point of vue : [march 25, 2019, chenghaozhu.net: Modularize your shiny app using shiny module and R6 class](http://www.chenghaozhu.net/posts/en/2019-03-25/). Have you a new point of vue or new information about that since one year and half ? – phili_b Jul 31 '19 at 08:16
  • @phili_b Currently, I am using the exact code that was outlined in the question. That is: to automatically assign IDs to R6 objects inside `global.R` and then using member functions (`ui()` and `bind()`) to connect them to the app. That said, the reason I used classes for this particular case was that I wanted polymorphism. Without that, a direct usage of modules is the best IMO – Gregor de Cillia Jul 31 '19 at 11:48
  • Ok. Thank you for your point of view :) – phili_b Jul 31 '19 at 12:23

2 Answers2

3

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)
Remko Duursma
  • 2,741
  • 17
  • 24
  • 1
    This seems dangerous to me. The class resides in the global scope, and is storing variables that likely should be in the server scope. This means multiple clients override eachothers settings. If you use an R6 object, you should either initialize it in the server scope, or track input/output/session of different clients and make sure any crosstalk is desired. – Erik A Sep 22 '21 at 14:30
1

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 :

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.

Edit July 6, 2023,for R6 sub module called in module, works also in module of 1st level of call:

  initialize = function(){
    ..
    self$ns = NS(session$ns(id)) # was self$ns = NS(id)

NS(session$ns(id)) inspired by SO: Access shiny module id within the modules server function

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(session$ns(id)) # for sub module of module
      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(session$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(session$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")                   
}
phili_b
  • 885
  • 9
  • 27