Question

以下是提示的问题：

我正在尝试复制可视化效果，因为每个网格图都有一个标题和一个副标题。但是，在我要复制的示例中，字幕（请参见上图）以比第二部分稍大的字体显示主要结果。格式如下：

99.85％/ 2.35小时

我希望百分比更大，而“ 2.35 hrs”部分要小一些，也许要小2个左右。最主要的是，这些所有者是按百分比衡量的，但是他们仍然询问总时数，所以我希望可以在这里，只是没有强调。添加趋势箭头也将很好，不确定执行此操作的最佳方法，但是如果对此也有建议，欢迎他们。

我不确定我是否可以做多个字幕，或者不确定是否可以采用不同的方式格式化单个字幕的每个部分。有什么建议吗？

我生成了以下代码来为报告/仪表板生成图表网格：

# Needed Libraries

library(Hmisc)
library(zoo)
library(lubridate)
library(ggplot2)
library(ggthemes)
library(grid)
library(gridExtra)

# Plot Function

metricplot <- function(data = criticalSystemAvailabilityFullDetail, row = 1) {

  # Since data is organized by row, I need to pull only the columns I need 
  # for the particular row (system) specificied. Then turn it into columns
  # since ggplot works best this way.
  ytdMonths <- as.data.frame(names(data)[4:((month(Sys.Date())-1)+3)])
  ytdValue <- t(as.data.frame(data[row,((month(Sys.Date()))+3):(ncol(data)-2)][1,]))
  ytdData <- cbind(ytdMonths, ytdValue)
  names(ytdData)[1] <- "Month"
  names(ytdData)[2] <- "Value"

  # Since I need red, yellow and green for my thresholds, I already have my 
  # target. My rules for this are basically, green until it exceeds 50%
  # of the target, then it turns yellow. Once it exceeds the Target, it turns
  # red. This function is called when the plot is made to determine the background
  # color.
  colour <- function (system = data[row,]) {
    if(data[row,ncol(data)] < as.numeric(strsplit(data[row,2], "%")[[1]][1]) ) {
      return("#fc5e58")
    } else if((data[row,ncol(data)] > as.numeric(strsplit(data[row,2], "%")[[1]][1])) == TRUE & (data[row,ncol(data)] < ((as.numeric(strsplit(data[row,2], "%")[[1]][1]) + 100.00) / 2)) == TRUE) {
      return("#ebc944")
    } else {
      return("#8BC34A")
    }
  }

  # Now for the plot. I have made some slight modifications to this. For example, in the white area that 
  # represents the high and low - I have used 100% for the max and the target for the low. I do this dynamically
  # by using the target from the row (system) I am currently plotting. I adjusted the line size down to 1, since 
  # the preivous value made the line a little too big. 
  plot <- 
    ggplot(ytdData) +
    annotate("rect", xmin = -Inf, xmax = Inf, ymax = 100.000, ymin = as.numeric(strsplit(data[row,2], "%")[[1]][1]), fill = "white", alpha = 0.6) + # Create the plot
    geom_line(aes(x = as.yearmon(Month), y = Value), colour = "white", size = 1) +
    labs(title = data[row,1], subtitle = paste0(data[row,ncol(data)], "% / ", data[row,(ncol(data)-1)], " hours")) + # Add title and subtitle
    theme(axis.line=element_blank(), # Remove X-axis title
          axis.text.x=element_blank(), # Remove X-Xais Text
          axis.text.y=element_blank(), # Remove Y-Axis Text - Comment this whole line out if you want a scale on the y-axis.
          axis.ticks=element_blank(), # Remove X-Axis
          axis.title.x=element_blank(), # Remove X-Axis Titlke
          axis.title.y=element_blank(),legend.position="none", # Remove legend and Y-axis title
          panel.background=element_blank(), # Remove bland gray background
          panel.border=element_blank(), # Remove border
          panel.grid.major=element_blank(), # Remove Grid
          panel.grid.minor=element_blank(), # Remove Grid
          plot.background = element_rect(fill = colour()), # Red, Green, Yellow
          plot.title = element_text(size = 10, colour = "white", face = "plain"), # Main Title
          plot.subtitle = element_text(size = 15, colour = "white", face = "bold"))

  return(plot) # Return the plot.
}



# Now we build the the grid by calling each row. Depending on the size of the canvas, 
# you might want to break up how many rows on the grid you do. In my case, this 
# is going on an A4 size peice of paper, so I will probably limit it to about 5-6 rows 
# in order to provide a readable page. Squeezing 5 columns in could get you more
# on a page, too. 

grid.arrange(metricplot2(data = criticalSystemAvailabilityFullDetail, row=1),
             metricplot2(data = criticalSystemAvailabilityFullDetail, row=2),
             metricplot2(data = criticalSystemAvailabilityFullDetail, row=3),
             metricplot2(data = criticalSystemAvailabilityFullDetail, row=4),
             metricplot2(data = criticalSystemAvailabilityFullDetail, row=5),
             metricplot2(data = criticalSystemAvailabilityFullDetail, row=5),
             metricplot2(data = criticalSystemAvailabilityFullDetail, row=7),
             metricplot2(data = criticalSystemAvailabilityFullDetail, row=8),
             metricplot2(data = criticalSystemAvailabilityFullDetail, row=9),
             metricplot2(data = criticalSystemAvailabilityFullDetail, row=10),
             metricplot2(data = criticalSystemAvailabilityFullDetail, row=11),
             metricplot2(data = criticalSystemAvailabilityFullDetail, row=12),
             metricplot2(data = criticalSystemAvailabilityFullDetail, row=13),
             metricplot2(data = criticalSystemAvailabilityFullDetail, row=14),
             metricplot2(data = criticalSystemAvailabilityFullDetail, row=15),
             metricplot2(data = criticalSystemAvailabilityFullDetail, row=16),
             metricplot2(data = criticalSystemAvailabilityFullDetail, row=17),
             metricplot2(data = criticalSystemAvailabilityFullDetail, row=18),
             metricplot2(data = criticalSystemAvailabilityFullDetail, row=19),
             metricplot2(data = criticalSystemAvailabilityFullDetail, row=20),
             metricplot2(data = criticalSystemAvailabilityFullDetail, row=21),
             metricplot2(data = criticalSystemAvailabilityFullDetail, row=22),
             metricplot2(data = criticalSystemAvailabilityFullDetail, row=23),
             metricplot2(data = criticalSystemAvailabilityFullDetail, row=24), ncol=4)

这将产生以下结果：

我尝试拍摄的原始概念如下：

谢谢！

Answer 1

较低级别的网格功能可能更适合自定义注释，例如

library(grid)

fancyGrob <- function(title = "Armani [Desktop]", 
                      number = "7880", 
                      percent = "45% ▼", 
                      d = list(raw = data.frame(x = 1:20, y = runif(20, 0.2, 1)), mean = 0.5), 
                      bkg = "#4DAF4A") {

  title <- textGrob(title, gp = gpar(col="white", fontsize = 18),
                    x = unit(5, 'pt'), y = unit(1, 'npc')- unit(0.1, 'line'), vjust = 1, hjust=0)
  number <- textGrob(number, gp = gpar(col="white", fontsize = 22, fontface=2),
                     x = unit(5, 'pt'), vjust = 0, hjust=0)
  y <- grobHeight(title) + grobHeight(number)
  number$y <- unit(1, 'npc') - 1.5*y 
  percent <- textGrob(paste0(" / ", percent), gp = gpar(col="white", fontsize = 10),
                     x = unit(5, 'pt') + grobWidth(number), 
                     y = unit(1, 'npc') - 1.5*y, vjust = 0, hjust=0)
  background <- rectGrob(gp=gpar(fill=bkg))

  p <- ggplot(d$raw, aes(x,y)) + 
    geom_area(aes(y=d$mean), fill='white', col=NA, alpha=0.5) +
    geom_line(col='white',  alpha=0.5, lwd=1.2) +
    scale_x_continuous(expand=c(0,0)) +
    scale_y_continuous(expand=c(0,0)) +
    theme_void() + theme(plot.margin = margin(5,5,5,5, unit = 'pt') )
  plot <- ggplotGrob(p)
  plot$vp <- viewport(height=0.5,just=c(0.5,1))
  grobTree(background, plot, number, percent, title, gp = gpar(fontfamily='Source Sans Pro'))

}

grid.arrange(grobs = replicate(7, fancyGrob(), simplify = FALSE))

Screensho

Answer 2

我修改了上面的代码以接收我的数据并根据需要显示。下面是此代码和示例输出。我只有两个小问题需要解决：

使用ALT-30和ALT-31粘贴或插入正在使用的“向上”和“向下”箭头。但是，当我保存文件时，它们被替换为UTF-8字符。不知道如何解决此问题.....我尝试使用不同的文件编码进行保存，并尝试找到无需更改即可工作的UTF-8字符。欢迎任何建议。

有人在不为每一行输入函数的情况下有关于如何构建grid.arrange（）选项的想法吗？也许某种循环将一系列字符串粘贴到变量中，然后在grid.arrange（）中使用该变量？不知道这是否行得通。只是试图使它自动化和标准化。

hoursPossible <- function(schedule, availabilityMonth, monthOrYear) {
    if(monthOrYear == "YTD") {
    fromDate <- ymd("2018-01-01")
    toDate <- ymd(ceiling_date(as.Date((as.yearmon(availabilityMonth))), "month") - 1)
  } else if(monthOrYear == "Month") {
    fromDate <- ymd(as.Date((as.yearmon(availabilityMonth))))
    toDate <- ymd(ceiling_date(as.Date((as.yearmon(availabilityMonth))), "month") - 1)
  }

  if(schedule == "24x7") {
    totalHoursPossible <- 24*(bizdays(from = fromDate, to=toDate)+1)
  } else if(schedule == "Business Hours") {
    totalHoursPossible <- 10.5*as.numeric((bizdays(from = fromDate, to = toDate, 'APSBusinessDays') + 1))
  } else if(schedule == "PV Business Hours") {
    totalHoursPossible <- 10.5*as.numeric((bizdays(from = fromDate, to = toDate, 'PVBusinessDays') + 1))
  } else if(schedule == "Field Hours") {
    totalHoursPossible <- 14.5*as.numeric((bizdays(from = fromDate, to = toDate, 'APSBusinessDays') + 1))
  }

  return(totalHoursPossible)
}


fancyGrob <- function(data = criticalSystemAvailabilityFullDetail, row = 1) {

  ytdData <- as.data.frame(names(data)[4:((month(Sys.Date())-1)+3)])
  names(ytdData)[1] <- "Month"
  ytdData$Month<- as.character(ytdData$Month)
  ytdData$monthlyHours <- as.numeric(data[row,4:(ncol(data)-2)])
  ytdData$cumulativeHoursYTD <- cumsum(as.numeric(data[row,4:(ncol(data)-2)]))
  ytdData$MonthlyPercentage <- NA
  ytdData$cumulativePercentage <- NA
  ytdData$direction <- NA


  schedule <- sub("^\\S+\\s+", '', data[row,2])
  committment <- strsplit(data[row,2], "%")[[1]][1]

  holidaysAPS <- c("2018-01-01", "2018-01-15", "2018-05-28", "2018-07-04", "2018-09-03", "2018-11-12", "2018-11-22", "2018-11-23", "2018-12-25")
  APSBusinessDays <-create.calendar(name='APSBusinessDays', holidays=holidaysAPS, weekdays=c('sunday', 'saturday'), adjust.from=adjust.next, adjust.to=adjust.previous)
  PVBusinessDays <-create.calendar(name='PVBusinessDays', holidays=holidaysAPS, weekdays=c('sunday', 'saturday', 'monday'), adjust.from=adjust.next, adjust.to=adjust.previous)


  for (i in 1: nrow(ytdData)) {
    ytdData[i,4] <- round((hoursPossible(schedule, availabilityMonth = ytdData[i,1], monthOrYear = "Month") - ytdData[i,2]) / (hoursPossible(schedule, availabilityMonth = ytdData[i,1], monthOrYear = "Month"))*100,3)
    ytdData[i,5] <- round((hoursPossible(schedule, availabilityMonth = ytdData[i,1], monthOrYear = "YTD") - ytdData[i,3]) / (hoursPossible(schedule, availabilityMonth = ytdData[i,1], monthOrYear = "YTD"))*100,3)
  }

  for(i in 2:nrow(ytdData)) {
    if(ytdData[i,5] == ytdData[i-1,5]) {
      ytdData[i,6] <- as.character("-")
    } else if (ytdData[i,5] > ytdData[i-1,5]) {
      ytdData[i,6] <- as.character("???")
    } else if (ytdData[i,5] < ytdData[i-1,5]) {
      ytdData[i,6] <- as.character("???")
    }
  }


  colour <- function (system = data[row,]) {
    if(data[row,ncol(data)] < as.numeric(strsplit(data[row,2], "%")[[1]][1]) ) {
      return("#fc5e58")
    } else if((data[row,ncol(data)] > as.numeric(strsplit(data[row,2], "%")[[1]][1])) == TRUE & (data[row,ncol(data)] < ((as.numeric(strsplit(data[row,2], "%")[[1]][1]) + 100.00) / 2)) == TRUE) {
      return("#ebc944")
    } else {
      return("#8BC34A")
    }
  }

  title <- textGrob(paste0(data[row,1]," [SLA: ", data[row,2],"]"), gp = gpar(col="white", fontsize = 10), x = unit(5, 'pt'), y = unit(1, 'npc')- unit(0.1, 'line'), vjust = 1, hjust=0)
  percent <- textGrob(paste0(ytdData[nrow(ytdData),5],"%"), gp = gpar(col="white", fontsize = 14, fontface=1), x = unit(5, 'pt'), vjust = 0, hjust=0)
  y <- grobHeight(title) + grobHeight(percent)
  percent$y <- unit(1, 'npc') - 1.5*y 
  hours <- textGrob(paste0(" / ", ytdData[nrow(ytdData),3]," ",ytdData[nrow(ytdData),6]), gp = gpar(col="white", fontsize = 10), x = unit(5, 'pt') + grobWidth(percent), y = unit(1, 'npc') - 1.5*y, vjust = 0, hjust=0)
  background <- rectGrob(gp=gpar(fill=colour()))

  p <- ggplot(ytdData, aes(x = as.yearmon(Month), y = cumulativePercentage)) +
    annotate("rect", xmin = -Inf, xmax = Inf, ymax = 100.000, ymin = as.numeric(committment), fill = "white", alpha = 0.6) +
    geom_line(col='white', lwd=1.0) +
    scale_x_continuous(expand=c(0,0)) +
    scale_y_continuous(expand=c(0,0)) +
    theme_void() +
    theme(plot.margin = margin(5,5,5,5, unit = 'pt'))


  plot <- ggplotGrob(p)
  plot$vp <- viewport(height=0.5,just=c(0.5,1))
  grobTree(background, plot, percent, hours, title, gp = gpar(fontfamily='Verdana'))

}


grid.arrange(fancyGrob(data = criticalSystemAvailabilityFullDetail, row = 1), 
             fancyGrob(data = criticalSystemAvailabilityFullDetail, row = 2), 
             fancyGrob(data = criticalSystemAvailabilityFullDetail, row = 3), 
             fancyGrob(data = criticalSystemAvailabilityFullDetail, row = 4), 
             fancyGrob(data = criticalSystemAvailabilityFullDetail, row = 5), 
             fancyGrob(data = criticalSystemAvailabilityFullDetail, row = 6), 
             fancyGrob(data = criticalSystemAvailabilityFullDetail, row = 7), 
             fancyGrob(data = criticalSystemAvailabilityFullDetail, row = 8),
             fancyGrob(data = criticalSystemAvailabilityFullDetail, row = 9),
             fancyGrob(data = criticalSystemAvailabilityFullDetail, row = 10),
             fancyGrob(data = criticalSystemAvailabilityFullDetail, row = 11),
             fancyGrob(data = criticalSystemAvailabilityFullDetail, row = 12),
             fancyGrob(data = criticalSystemAvailabilityFullDetail, row = 13),
             fancyGrob(data = criticalSystemAvailabilityFullDetail, row = 14),
             fancyGrob(data = criticalSystemAvailabilityFullDetail, row = 15),
             fancyGrob(data = criticalSystemAvailabilityFullDetail, row = 16),
             fancyGrob(data = criticalSystemAvailabilityFullDetail, row = 17),
             fancyGrob(data = criticalSystemAvailabilityFullDetail, row = 18), ncol=3)

具有不同大小字体的R ggplot字幕

2 个答案: