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).
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
.
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 }) } ) )
myObj <- MyModule$new() shinyApp( myObj$ui(), function(input, output, session){ myObj$bind() } )
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) } )
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.callModule
because of nesting. Can anyone show a use/case where this approach fails?Thanks in advance for any inputs about this topic!
Shiny modules have two big advantages. Firstly, namespacing makes it easier to understand how your app works because you can write, analyse, and test individual components in isolation. Secondly, because modules are functions they help you reuse code; anything you can do with a function, you can do with a module.
Using object oriented programming (OOP) in the Shiny App allows developers to organize the code in the packs object-attributes-functions.
A Shiny app consists of two parts, a user interface ( ui ) and an R session that runs code and returns results ( server ). These two parts can be in their own files called ui. R and server. R, or they can be combined into a single file called app.
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:
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.
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") }
If you love us? You can donate to us via Paypal or buy me a coffee so we can maintain and grow! Thank you!
Donate Us With