我目前正在R6课程中包装闪亮的模块，并希望听到有关此设计的一些意见。
基本上，我对一种干净的方法（可读代码）感兴趣，并希望这些类允许嵌套（参见嵌套模块部分here）。当前的代码符合这两个标准，但我对实现的细节有一些疑问（参见下面的“问题”）。
我正在编写多态模块，并认为R6是继承模块之间某些行为的好方法。创建的对象跨会话共享数据（未包含在下面的示例中），因此我在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()是否安全？如果没有，base包中是否有类似的功能？我真的想限制我正在开发的包的依赖关系。callModule周围使用包装器。任何人都可以展示这种方法失败的用途/案例吗？提前感谢您对此主题的任何意见！
答案 0 :(得分：2)
我知道这是一篇非常古老的文章，但我想在这里发布，因为我真的很喜欢这种方法。几个月前，我读了这篇文章，从那以后，在某些情况下应用了它，我认为还会有更多。尽管闪亮的模块很棒，但是将闪亮的模块包装在R6对象中是组织代码的又一步。当应用程序变得非常大时，将ui和服务器函数中的代码最小化，而是调用定义良好的R6对象的方法，将是非常有利的。
我发现真正有用的一件事是，OP中定义的R6对象可以同时包含多个UI方法，和多个服务器方法。这样，可以将“属于”的不同UI元素视为同一对象的方法。每个UI元素都可以具有自己的服务器功能（或没有服务器功能）。
为了演示，请看下面的示例。请注意：可以通过更少的代码来实现此特定示例，但真正的目的是在有光泽的应用程序的主UI和服务器功能中调用简单方法。这使得那里的逻辑真的很明显，并节省了很多时间来复制应用程序的各个部分等。
以下示例使R6对象具有用于输入部分的UI方法（选择数据集的列）和具有反应性的绘图方法（使用这些列）。所有数据都存储在对象内部，因此无需在服务器函数中传递数据。我们最终得到了一个非常非常短的闪亮应用程序（一旦定义了对象）。
OP使用单个bind方法来运行单个服务器功能。在这里，我们有两个服务器功能，每个功能都定义为对象的清晰方法。使用两个UI功能，我们还需要生成两个ID。否则，方法就是作为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)
答案 1 :(得分：1)
我是R6和OOP的初学者。
这是我在两个面板中调用R6模块的经典Shiny代码中完成的一个表达。
灵感来自：
编辑（在我的POC开头读取并应用，但尚未链接）：
reactive(myreactive())。 /编辑
对于最后两个问题：
edit2：
代码已更新：已添加observeEvent(..[R6 module called]..., once=TRUE)，已修复错误，已删除隐藏的textInput()
Modules_R6_Examples.R
# called in l'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,
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,
# 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(),
RapportCourant = self$RapportCourant.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 = RapportCourant
)
}else return()
},
ChoixDimRegroupSERVER = function(input, output, session,
input_maitre_rows_selected
) {
output$ChoixDimRegroupUI <- renderUI(private$checkboxGroupInput_renderUI(input_maitre_rows_selected() ))
self$RapportCourant.react<-reactive(private$RapportCourant.fct(input$ChoixRapport))
},
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(input_ChoixDimRegroup, RapportCourant=self$RapportCourant.react()) {
if (is.null(input_ChoixDimRegroup)) {
list_colonnes<- RapportCourant
} else {
list_colonnes<-input_ChoixDimRegroup
}
div(
span("Regroupement choisi : "),
div(p(paste(unlist(list_colonnes),collapse=', ')), class="gras")
)
},
ConsolidationDataTable_renderDT=function(input_ChoixDimRegroup,
RapportCourant=self$RapportCourant.react(),
DetailsTable=self$DetailsTable,
ConsolidationFormatOutput.Fct=self$ConsolidationFormatOutput.Fct){
res<-NULL
if (is.null(input_ChoixDimRegroup)) {
list_colonnes<-RapportCourant
} else {
list_colonnes<-input_ChoixDimRegroup
}
res<- DetailsTable()
if (!is.null(res)) {
res2 <- (res
%>% group_by_at(., .vars = list_colonnes)
%>% 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(input$ChoixDimRegroup))
},
ConsolidationDataTableSERVER = function(input, output, session ) {
output$ConsolidationDataTableUI <- DT::renderDataTable(private$ConsolidationDataTable_renderDT(input$ChoixDimRegroup))
},
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")
}