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!
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 :
edit (read and applied at the beginning of my POC, but not linked yet):
reactive(myreactive())
in the call of modules. /edit
For the two last questions:
edit2:
code updated : observeEvent(..[R6 module called]..., once=TRUE)
added, bugs fixed, hidden textInput()
removed
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")
}
The technical post webpages of this site follow the CC BY-SA 4.0 protocol. If you need to reprint, please indicate the site URL or the original address.Any question please contact:yoyou2525@163.com.