我最近在分析胆汁酸的数据，所以想画个堆积柱状图，看看组间情况，大概的设想就是这样：
因为胆汁酸根据来源可以分为初级胆汁酸、次级胆汁酸以及胆汁酸代谢产物，所以就想着，柱状图也可以根据每个类别进行不同着色（分类内的条目为对应色系的渐变色），进一步观察来源分类上的差异：
画图其实不难，先为每种胆汁酸设置对应的颜色（我后续要拼图），然后再作图。这里代码就不 show 了，下面 shiny 的代码也会提到。
改造成 Shiny App
成品展示
这是主界面：
可以看到界面主要分成四个区域，分别完成上传，预览，设置作图参数和绘图的功能（绘图区是隐藏的，等按下 Plot 按钮后会显示）。
若不上传数据，则默认使用示例数据作图。
这里需要输入三个文件（需用 TAB 分割）：
•count file：数据矩阵，行为样本，列为数据条目
代码语言：javascript复制 A B C D E F G H I J K L M N OSample1 10 10 10 10 5 5 5 5 5 40 40 20 20 20 20Sample2 20 20 20 20 5 5 5 5 5 40 40 20 20 20 20Sample3 20 20 20 20 5 5 5 5 5 40 40 20 20 20 20Sample4 30 30 30 30 5 5 5 5 5 40 40 20 20 20 20Sample5 35 35 35 35 5 5 5 5 5 40 40 20 20 20 20Sample6 41 41 41 41 5 5 5 5 5 40 40 20 20 20 20Sample7 47 47 47 47 5 5 5 5 5 40 40 20 20 20 20Sample8 53 53 53 53 5 5 5 5 5 40 40 20 20 20 20Sample9 5 5 5 5 10 10 10 10 10 20 20 20 20 40 40Sample10 5 5 5 5 20 20 20 20 20 20 20 20 20 40 40Sample11 5 5 5 5 20 20 20 20 20 20 20 20 20 40 40Sample12 5 5 5 5 30 30 30 30 30 20 20 20 20 40 40Sample13 5 5 5 5 35 35 35 35 35 20 20 20 20 40 40Sample14 5 5 5 5 41 41 41 41 41 20 20 20 20 40 40Sample15 5 5 5 5 47 47 47 47 47 20 20 20 20 40 40Sample16 5 5 5 5 53 53 53 53 53 20 20 20 20 40 40•group file：样本分组信息，第一列为样本，样本名需和第一个数据矩阵中的相同，第二列为分组
代码语言：javascript复制SampleID GroupSample1 group1Sample2 group1Sample3 group1Sample4 group1Sample5 group1Sample6 group1Sample7 group1Sample8 group1Sample9 group2Sample10 group2Sample11 group2Sample12 group2Sample13 group2Sample14 group2Sample15 group2Sample16 group2•color file：数据分组信息，第二列填什么其实无所谓，实际程序只会统计第二列有几个分类，我这里用 1，2，3，4 来代表数据条目的四个分组，第一列需与第一个数据矩阵中的列名相同
代码语言：javascript复制Taxa ColorA 1B 1C 1D 1E 2F 2G 2H 2I 2J 3K 3L 4M 4N 4O 4上传文件后，可以在右侧预览文件区查看上传的三个文件，检查上传文件是否有误，若没有正常读取这边会显示报错：
确认数据无误后就可以绘图啦，在左侧自定义参数区可以设置一些绘图参数（当然也可以绘图后再调整）：
点击 Plot 按钮即可出图，点击按钮后，右侧会出现绘图区域，每张图都为大家准备了下载 PDF 和 PNG 的按钮。
默认情况下绘图区会出现两张图。
第一张图是根据数据的分类进行着色（为每个分类随机匹配一种颜色，相应分类内为对应色系的渐变色）：
因为第一张图是随机颜色，所以也十分贴心的为大家加上了重新生成第一张图的按钮 【Re-generate】，点击该按钮后会换一种随机配色：
第二张图是为每一列条目进行着色（为每个条目随机匹配一种颜色，调色板可在左侧自定义参数区调整）：
这里可调整第二张图的调色板：
默认情况下是做这两张图，可能有小伙伴就会说，我这个第一张图只能随机生成颜色，可不可以为每个分类自定义颜色呢？
这当然可以，在左侧自定义参数区有个选项【Custom colors for each taxon group】:
把这个小勾勾打上程序就会根据你的类别数据出现相应数量的取色器（示例数据中是 4 类）：
然后再点击绘图按钮，就会出现自定义分类颜色的第三张图啦：
这就是这个网站的主要功能。下面给大家简单讲讲我的设计思路。
设计思路
网页界面（ui.R）
因为这个网站的主要目的是作图，那么其实不难想到我们大概要分成四个板块，分别完成上传，预览数据，设置作图参数和绘图的功能。
主体框架
代码语言：javascript复制library(shinydashboard)body <- dashboardBody( fluidRow( column(width = 4, box( title = "Upload", status = "primary", solidHeader = TRUE, collapsible = TRUE,width = NULL ), box( title = "Customize", status = "warning", solidHeader = TRUE, collapsible = TRUE,width = NULL) ), column(width = 8, tabBox( title = "Input Data" ), uiOutput("ui"), uiOutput("textanno") ) ))shinyUI( dashboardPage( dashboardHeader(title = "Stacked bar chart"), dashboardSidebar( disable = TRUE), body ))我这里依旧使用了熟悉的 shinydashboard，但因为只需要 body 部分，所以就没有设置侧边栏 dashboardSidebar(disable = TRUE)。
排版先用 column 将主体分为两列，左列较窄 width = 4 用做上传文件区和自定义参数区，右列宽一些 width = 8 用做预览文件区和绘图区。
左列用两个 box 分别划分为传文件区和自定义参数区；右列用 tabBox 来生成预览文件区和绘图区，因为有会有三个上传文件和三幅图，用 tabBox 便于切换。
因为我想等按下按钮后再出现绘图区，所以这里使用了 uiOutput() 来生成绘图区 UI 。
上传文件区
使用 fileInput() 来上传文件：
box( title = "Upload", status = "primary", solidHeader = TRUE, collapsible = TRUE,width = NULL, h5("Upload tab-delimited text files."), fileInput("counts", "Choose count file(.tsv)", multiple = FALSE, accept = c(".txt")), fileInput("groups", "Choose group file(.tsv)", multiple = FALSE, accept = c(".txt")), fileInput("colors", "Choose color file(.tsv)", multiple = FALSE, accept = c(".txt")) )自定义参数区
在自定义参数区我选择了几个常用的参数进行自定义，包括：
•X 轴字体大小•Y 轴名称•Y 轴字体大小•第二张图的配色方案，这里用了 RColorBrewer 中的 qual 色板•输出图片的长宽•第三张图的自定义配色方案（使用了 uiOutput()，只有 Custom colors for each taxon group 选项打上勾时才会显示取色器 UI，这部分会在 server.R 中介绍）
根据不同的选项类型，选择使用不同的输入方案，比如：
•sliderInput() 滑块选择•textInput() 文本输入•selectizeInput() 下拉菜单•colourInput() 取色器，需用到 library(colourpicker)
box( title = "Customize", status = "warning", solidHeader = TRUE, collapsible = TRUE,width = NULL, sliderInput("xfontsize", "X axis label font size", min = 0, max = 30, value = 15 ), textInput("ylabel", "Y axis label", value = "Relative Abundance"), sliderInput("yfontsize", "Y axis label font size", min = 0, max = 30, value = 15 ), sliderInput("tyfontsize", "Y axis title font size", min = 0, max = 30, value = 15 ), selectizeInput('colpal', "Choose a color palette (Plot 2)", selected = "Set3", choices = rownames(brewer.pal.info[brewer.pal.info$category=="qual",])), sliderInput("plotheight", "Height (pixels)", min = 400, max = 1000, value = 460, step = 20 ), sliderInput("plotwidth", "Width (pixels)", min = 400, max = 1000, value = 400, step = 20 ), checkboxInput("customcol", "Custom colors for each taxon group"), uiOutput("colourpickers"), actionButton("run", label = "Plot", icon = icon("paper-plane")) )预览文件区
用 reactableOutput() 可视化响应式表格：
tabBox( title = "Input Data", id = "tabset1",width = NULL, tabPanel("Count", reactableOutput("ct_table")), tabPanel("Group", reactableOutput("gp_table")), tabPanel("Color", reactableOutput("cl_table")) )绘图区
同样使用了 uiOutput()，只有点击 【Plot】按钮后才会显示绘图区 UI，这部分会在 server.R 中介绍。
uiOutput("ui"),uiOutput("textanno")ui.R
代码语言：javascript复制library(shiny)library(RColorBrewer)library(reshape2)library(ggpubr)library(colourpicker)library(colorspace)library(shinycssloaders)library(shinydashboard)library(reactable)body <- dashboardBody( fluidRow( column(width = 4, box( title = "Upload", status = "primary", solidHeader = TRUE, collapsible = TRUE,width = NULL, h5("Upload tab-delimited text files."), fileInput("counts", "Choose count file(.tsv)", multiple = FALSE, accept = c(".txt")), fileInput("groups", "Choose group file(.tsv)", multiple = FALSE, accept = c(".txt")), fileInput("colors", "Choose color file(.tsv)", multiple = FALSE, accept = c(".txt")) ), box( title = "Customize", status = "warning", solidHeader = TRUE, collapsible = TRUE,width = NULL, sliderInput("xfontsize", "X axis label font size", min = 0, max = 30, value = 15 ), textInput("ylabel", "Y axis label", value = "Relative Abundance"), sliderInput("yfontsize", "Y axis label font size", min = 0, max = 30, value = 15 ), sliderInput("tyfontsize", "Y axis title font size", min = 0, max = 30, value = 15 ), selectizeInput('colpal', "Choose a color palette (Plot 2)", selected = "Set3", choices = rownames(brewer.pal.info[brewer.pal.info$category=="qual",])), sliderInput("plotheight", "Height (pixels)", min = 400, max = 1000, value = 460, step = 20 ), sliderInput("plotwidth", "Width (pixels)", min = 400, max = 1000, value = 400, step = 20 ), checkboxInput("customcol", "Custom colors for each taxon group"), uiOutput("colourpickers"), actionButton("run", label = "Plot", icon = icon("paper-plane")) ) ), column(width = 8, tabBox( title = "Input Data", id = "tabset1",width = NULL, tabPanel("Count", reactableOutput("ct_table")), tabPanel("Group", reactableOutput("gp_table")), tabPanel("Color", reactableOutput("cl_table")) ), uiOutput("ui"), uiOutput("textanno") ) ))shinyUI( dashboardPage( dashboardHeader(title = "Stacked bar chart"), dashboardSidebar( disable = TRUE), body ))后台程序（server.R）
需要的包：
代码语言：javascript复制library(shiny)library(RColorBrewer)library(reshape2)library(ggpubr)library(colourpicker)library(colorspace)library(shinycssloaders)library(shinydashboard)library(reactable)因为作图需要渐变色，所以我先整了个渐变色的函数，这里用到了 colorspace::lighten() 使颜色变淡，输入为一个颜色的十六进制代码和该分类下的条目数量：
color_lighten <- function(cc,num){ tmp <- c() ln <- 0.8/num for (i in seq(num)) { tmp <- c(tmp,lighten(cc, i*ln)) } return(rev(tmp))}然后定义第一张图的随机颜色，用到了 RColorBrewer 中的 seq 色板：
color_list = rownames(brewer.pal.info[brewer.pal.info$category=="seq",])下面开始写主程序，这里我只会介绍一些关键的代码片段，完整代码在最后。
为输出文件定义临时目录
代码语言：javascript复制td <- tempdir()判断是否有文件输入
这里程序会判断是否有文件上传，如果没有则上传文件则会使用示例数据绘图：
代码语言：javascript复制counts <- reactive({ ifelse(is.null(input$counts), data <- read.table("./www/counts.txt",header = TRUE,sep = "t",row.names = 1,check.names=FALSE), data <- read.table(input$counts$datapath,header = TRUE,sep = "t",row.names = 1,check.names=FALSE) ) data })判断用户上传的文件是否正确解析
代码语言：javascript复制output$ct_table <- renderReactable({ validate( need(try(counts() != ""),"Please upload count file") ) reactable(counts()) })如果程序没有正确读取输入文件，会输出提示信息。
生成第三张图的取色板
使用了 renderUI()，只有当 Custom colors for each taxon group 选项打上勾 input$customcol 为 TRUE 时才会显示取色器 UI，这里也用到了一个批量生成 UI 元素的技巧，根据所需颜色的数量来自动生成相应数量的取色板：
output$colourpickers <- renderUI({ if(input$customcol){ if(!is.null(colors())){ pvars <- length(unique(colors()$color)) }else{ validate( need(input$colors,"Please upload color file") ) } pvars <- length(unique(colors()$color)) lapply(seq(pvars), function(i) { colourInput(paste0("col", i), paste0("Select colour ", i),"#D42424") }) } })重制第一张图的随机配色
用 observeEvent() 判断 Re-generate 按钮的状态，并重制颜色：
observeEvent(input$rep,{ colors <- colors() groups <- groups() counts <- counts() counts[is.na(counts)] <- 0# `RColorBrewer` 中的 `seq` 色板共有 18 种颜色，这里用 sample 进行随机抽取 color_l <- sample(1:18, length(unique(colors$color)), replace = FALSE) tmp <- c() for (i in 1:length(color_l)) { tmp<- c(tmp,colorRampPalette(brewer.pal(9,color_list[color_l[i]])[c(3,5,7)])(data.frame(table(colors$color))$Freq[i])) } colors$my_color <- tmp counts$group <- groups$group tmp <- melt(counts,id.vars="group") tmp$variable <- factor(tmp$variable, levels = colors$taxa)# 绘制堆积柱状图 p1 <- ggplot(tmp,aes(group,value,fill=variable)) geom_bar(stat="identity",position = "fill",width = 0.8,size=0.25) xlab("") ylab(input$ylabel) scale_y_continuous(labels = scales::percent) scale_fill_manual(values = colors$my_color) guides(fill=guide_legend(title=NULL)) theme(axis.text.x=element_text(size=input$xfontsize), axis.text.y=element_text(size=input$yfontsize), axis.title.y=element_text(size=input$tyfontsize), panel.grid = element_blank(), panel.background = element_rect(color = 'black', fill = 'transparent'))# 保存文件到临时目录下 ggsave(paste0(td,"/p1.pdf"),plot = p1, width = input$plotwidth/96, height = input$plotheight/96) ggsave(paste0(td,"/p1.png"),plot = p1, width = input$plotwidth/96, height = input$plotheight/96) output$stp1 <- renderPlot(p1) })绘制自定义配色图（第三张图）
判断选项框状态 input$customcol，并绘制 UI（这里我选择重新做三张图，其实应该有效率更高的办法来实现动态插入 tabPanel，但试了一圈方法都没能实现，只能选择最傻瓜的方法，以后有空再研究下）：
observeEvent(input$run,{ ... ... if(input$customcol){ output$ui <- renderUI({ tabBox( title = "Plot Area", id = "plotarea",width = NULL, tabPanel("Plot 1", h4("Random colors for each taxon group"), plotOutput("stp1", width = input$plotwidth, height = input$plotheight) %>% withSpinner(), actionButton("rep", label = "Re-generate"), downloadButton("downloadp1", "Save PDF", icon = icon("download")), downloadButton("downloadp1png", "Save PNG", icon = icon("download"))), tabPanel("Plot 2", h4("Random colors for each taxon"), plotOutput("stp2", width = input$plotwidth, height = input$plotheight) %>% withSpinner(), downloadButton("downloadp2", "Save PDF", icon = icon("download")), downloadButton("downloadp2png", "Save PNG", icon = icon("download"))), tabPanel("Plot 3", h4("Custom colors for each taxon group"), plotOutput("stp3", width = input$plotwidth, height = input$plotheight) %>% withSpinner(), downloadButton("downloadp3", "Save PDF", icon = icon("download")), downloadButton("downloadp3png", "Save PNG", icon = icon("download"))) ) }) }})下载 PDF 和 PNG
使用 downloadHandler() 定义下载事件：
output$downloadp1 <- downloadHandler( filename <- function() { paste("p1", "pdf", sep=".") }, content <- function(file) { file.copy(paste0(td,"/p1.pdf"), file) })output$downloadp1png <- downloadHandler( filename <- function() { paste("p1", "png", sep=".") }, content <- function(file) { file.copy(paste0(td,"/p1.png"), file) })server.R
代码语言：javascript复制/*
* 提示：该行代码过长，系统自动注释不进行高亮。一键复制会移除系统注释
* ## This is the server logic of a Shiny web application. You can run the # application by clicking 'Run App' above.## Find out more about building applications with Shiny here:# # http://shiny.rstudio.com/#library(shiny)library(RColorBrewer)library(reshape2)library(ggpubr)library(colourpicker)library(colorspace)library(shinycssloaders)library(shinydashboard)library(reactable)color_lighten <- function(cc,num){ tmp <- c() ln <- 0.8/num for (i in seq(num)) { tmp <- c(tmp,lighten(cc, i*ln)) } return(rev(tmp))}color_list = rownames(brewer.pal.info[brewer.pal.info$category=="seq",])# Define server logic required to draw a histogramshinyServer(function(input, output) { td <- tempdir() counts <- reactive({ ifelse(is.null(input$counts), data <- read.table("./www/counts.txt",header = TRUE,sep = "t",row.names = 1,check.names=FALSE), data <- read.table(input$counts$datapath,header = TRUE,sep = "t",row.names = 1,check.names=FALSE) ) data }) colors <- reactive({ ifelse(is.null(input$colors), data <- read.table("./www/colors.txt",header = TRUE,sep = "t",check.names=FALSE), data <- read.table(input$colors$datapath,header = TRUE,sep = "t",check.names=FALSE) ) colnames(data) <- c("taxa","color") data }) groups <- reactive({ ifelse(is.null(input$groups), data <- read.table("./www/group.txt",header = TRUE,sep="t",check.names=FALSE), data <- read.table(input$groups$datapath,header = TRUE,sep = "t",check.names=FALSE) ) colnames(data) <- c("sample","group") data }) output$ct_table <- renderReactable({ validate( need(try(counts() != ""),"Please upload count file") ) reactable(counts()) }) output$gp_table <- renderReactable({ validate( need(try(groups() != ""),"Please upload group file") ) reactable(groups()) }) output$cl_table <- renderReactable({ validate( need(try(colors() != ""),"Please upload color file") ) reactable(colors()) }) output$downloadp1 <- downloadHandler( filename <- function() { paste("p1", "pdf", sep=".") }, content <- function(file) { file.copy(paste0(td,"/p1.pdf"), file) }) output$downloadp1png <- downloadHandler( filename <- function() { paste("p1", "png", sep=".") }, content <- function(file) { file.copy(paste0(td,"/p1.png"), file) }) output$downloadp2 <- downloadHandler( filename <- function() { paste("p2", "pdf", sep=".") }, content <- function(file) { file.copy(paste0(td,"/p2.pdf"), file) }) output$downloadp2png <- downloadHandler( filename <- function() { paste("p2", "png", sep=".") }, content <- function(file) { file.copy(paste0(td,"/p2.png"), file) }) output$downloadp3 <- downloadHandler( filename <- function() { paste("p3", "pdf", sep=".") }, content <- function(file) { file.copy(paste0(td,"/p3.pdf"), file) }) output$downloadp3png <- downloadHandler( filename <- function() { paste("p3", "png", sep=".") }, content <- function(file) { file.copy(paste0(td,"/p3.png"), file) }) output$colourpickers <- renderUI({ if(input$customcol){ if(!is.null(colors())){ pvars <- length(unique(colors()$color)) }else{ validate( need(input$colors,"Please upload color file") ) } pvars <- length(unique(colors()$color)) lapply(seq(pvars), function(i) { colourInput(paste0("col", i), paste0("Select colour ", i),"#D42424") }) } }) observeEvent(input$rep,{ colors <- colors() groups <- groups() counts <- counts() counts[is.na(counts)] <- 0 color_l <- sample(1:18, length(unique(colors$color)), replace = FALSE) tmp <- c() for (i in 1:length(color_l)) { tmp<- c(tmp,colorRampPalette(brewer.pal(9,color_list[color_l[i]])[c(3,5,7)])(data.frame(table(colors$color))$Freq[i])) } colors$my_color <- tmp counts$group <- groups$group tmp <- melt(counts,id.vars="group") tmp$variable <- factor(tmp$variable, levels = colors$taxa) p1 <- ggplot(tmp,aes(group,value,fill=variable)) geom_bar(stat="identity",position = "fill",width = 0.8,size=0.25) xlab("") ylab(input$ylabel) scale_y_continuous(labels = scales::percent) scale_fill_manual(values = colors$my_color) guides(fill=guide_legend(title=NULL)) theme(axis.text.x=element_text(size=input$xfontsize), axis.text.y=element_text(size=input$yfontsize), axis.title.y=element_text(size=input$tyfontsize), panel.grid = element_blank(), panel.background = element_rect(color = 'black', fill = 'transparent')) ggsave(paste0(td,"/p1.pdf"),plot = p1, width = input$plotwidth/96, height = input$plotheight/96) ggsave(paste0(td,"/p1.png"),plot = p1, width = input$plotwidth/96, height = input$plotheight/96) output$stp1 <- renderPlot(p1) }) observeEvent(input$run,{ colors <- colors() groups <- groups() counts <- counts() counts[is.na(counts)] <- 0 color_l <- sample(1:18, length(unique(colors$color)), replace = FALSE) tmp <- c() for (i in 1:length(color_l)) { tmp<- c(tmp,colorRampPalette(brewer.pal(9,color_list[color_l[i]])[c(3,5,7)])(data.frame(table(colors$color))$Freq[i])) } colors$my_color <- tmp counts$group <- groups$group tmp <- melt(counts,id.vars="group") tmp$variable <- factor(tmp$variable, levels = colors$taxa) p1 <- ggplot(tmp,aes(group,value,fill=variable)) geom_bar(stat="identity",position = "fill",width = 0.8,size=0.25) xlab("") ylab(input$ylabel) scale_y_continuous(labels = scales::percent) scale_fill_manual(values = colors$my_color) guides(fill=guide_legend(title=NULL)) theme(axis.text.x=element_text(size=input$xfontsize), axis.text.y=element_text(size=input$yfontsize), axis.title.y=element_text(size=input$tyfontsize), panel.grid = element_blank(), panel.background = element_rect(color = 'black', fill = 'transparent')) ggsave(paste0(td,"/p1.pdf"), plot = p1, width = input$plotwidth/96, height = input$plotheight/96) ggsave(paste0(td,"/p1.png"), plot = p1, width = input$plotwidth/96, height = input$plotheight/96) colors$my_color <- colorRampPalette(brewer.pal(8, input$colpal))(length(unique(colors$taxa))) p2 <- ggplot(tmp,aes(group,value,fill=variable)) geom_bar(stat="identity",position = "fill",width = 0.8,size=0.25) xlab("") ylab(input$ylabel) scale_y_continuous(labels = scales::percent) scale_fill_manual(values = colors$my_color) guides(fill=guide_legend(title=NULL)) theme(axis.text.x=element_text(size=input$xfontsize), axis.text.y=element_text(size=input$yfontsize), axis.title.y=element_text(size=input$tyfontsize), panel.grid = element_blank(), panel.background = element_rect(color = 'black', fill = 'transparent')) ggsave(paste0(td,"/p2.pdf"),plot = p2, width = input$plotwidth/96, height = input$plotheight/96) ggsave(paste0(td,"/p2.png"),plot = p2, width = input$plotwidth/96, height = input$plotheight/96) output$stp1 <- renderPlot(p1) output$stp2 <- renderPlot(p2) if(input$customcol){ output$ui <- renderUI({ tabBox( title = "Plot Area", id = "plotarea",width = NULL, tabPanel("Plot 1", h4("Random colors for each taxon group"), plotOutput("stp1", width = input$plotwidth, height = input$plotheight) %>% withSpinner(), actionButton("rep", label = "Re-generate"), downloadButton("downloadp1", "Save PDF", icon = icon("download")), downloadButton("downloadp1png", "Save PNG", icon = icon("download"))), tabPanel("Plot 2", h4("Random colors for each taxon"), plotOutput("stp2", width = input$plotwidth, height = input$plotheight) %>% withSpinner(), downloadButton("downloadp2", "Save PDF", icon = icon("download")), downloadButton("downloadp2png", "Save PNG", icon = icon("download"))), tabPanel("Plot 3", h4("Custom colors for each taxon group"), plotOutput("stp3", width = input$plotwidth, height = input$plotheight) %>% withSpinner(), downloadButton("downloadp3", "Save PDF", icon = icon("download")), downloadButton("downloadp3png", "Save PNG", icon = icon("download"))) ) }) output$textanno <- renderUI({ tags$div( tags$h4("Plot1: Random colors for each taxon group"), tags$h4("Plot2: Random colors for each taxon"), tags$h4("Plot3: Custom colors for each taxon group") ) }) custom_colors <- c() for (i in seq(length(unique(colors$color)))) { custom_colors <-c(custom_colors, color_lighten(eval(parse(text = paste0("input$col", i))), data.frame(table(colors$color))$Freq[i])) } colors$my_color <- custom_colors p3 <- ggplot(tmp,aes(group,value,fill=variable)) geom_bar(stat="identity",position = "fill",width = 0.8,size=0.25) xlab("") ylab(input$ylabel) scale_y_continuous(labels = scales::percent) scale_fill_manual(values = colors$my_color) guides(fill=guide_legend(title=NULL)) theme(axis.text.x=element_text(size=input$xfontsize), axis.text.y=element_text(size=input$yfontsize), axis.title.y=element_text(size=input$tyfontsize), panel.grid = element_blank(), panel.background = element_rect(color = 'black', fill = 'transparent')) ggsave(paste0(td,"/p3.pdf"),plot = p3, width = input$plotwidth/96, height = input$plotheight/96) ggsave(paste0(td,"/p3.png"),plot = p3, width = input$plotwidth/96, height = input$plotheight/96) output$stp3 <- renderPlot(p3) } else{ output$textanno <- renderUI({ tags$div( tags$h4("Plot1: Random colors for each taxon group"), tags$h4("Plot2: Random colors for each taxon") ) }) output$ui <- renderUI({ tabBox( title = "Plot Area", id = "plotarea",width = NULL, tabPanel("Plot 1", h4("Random colors for each taxon group"), plotOutput("stp1", width = input$plotwidth, height = input$plotheight) %>% withSpinner(), actionButton("rep", label = "Re-generate"), downloadButton("downloadp1", "Save PDF", icon = icon("download")), downloadButton("downloadp1png", "Save PNG", icon = icon("download"))), tabPanel("Plot 2", h4("Random colors for each taxon"), plotOutput("stp2", width = input$plotwidth, height = input$plotheight) %>% withSpinner(), downloadButton("downloadp2", "Save PDF", icon = icon("download")), downloadButton("downloadp2png", "Save PNG", icon = icon("download"))) ) }) } })})
*/本次练习的代码和示例数据已上传至 GitHub：https://github.com/zwbao/shinyapps
另外，这个堆积柱状图插件也已在 Hiplot 平台上线，欢迎大家试用：https://hiplot.com.cn/advance/stacked-bar
这次的代码写的比较粗糙，还有很多可以改进的地方，欢迎各位批评指正 ~
