#' Create a function to jitter the binary outcome (p89)
#'
#' @param a column with values of 0 or 1
#' @param jitt amount of horizontal and vertical jitter, value between 0 and .5; defaults to .05
#'
#' @return Takes a binary variable and randomly spreads it within 0 and 1
#'
#' @details From Andrew Gelman and Jennifer Hill. For use in graphs
#' to show the quantity of variable that otherwise would be stuck
#' on a single lines at 0 and 1. This is different from geom_jitter
#' because it keeps all the data within the possible range of the variable,
#' not allowing values greater than 1 or less than 0.
#'
#' @examples jitter_binary(contract$b_CBre)
#'
#' @import ggplot2
#' @export
jitter_binary<-function(a, jitt = 0.05){
if_else(a==0,runif(length(a),0,jitt),runif(length(a),1-jitt,1))
}
#' Get Plot Theme
#'
#' @return Thematic elements that can be added to a plot.
#'
#' @details A standard set of style elements that is applied
#' across csis360 plots by default. These can be overriden,
#' by adding different theme elements after adding this to
#' your plot.
#'
#' @examples FullData<-standardize_variable_names(Path,
#' FullData)
#'
#' @import ggplot2
#' @import sysfonts
#' @export
get_plot_theme<-function(erase_legend_title=TRUE,blank_x_lines=TRUE){
#Make sure Open Sans is available.
# if(!"Open Sans" %in% sysfonts::font_families()) sysfonts::font_add_google("Open Sans")
t<-theme(
panel.background = element_rect(fill = "#F4F4F4"),
strip.background = element_rect(fill ="#E0E0E0"),
plot.background = element_rect(fill = "white", color="white"),
panel.grid.major.y = element_line(size=.1, color="gray"),
panel.grid.minor.y = element_line(size=.1, color="lightgray"),
plot.margin = margin(t=0,r=0.25,b=0.1,l=0.1,"inches")
)
if(blank_x_lines==TRUE){
t<-t+theme(
panel.grid.major.x = element_blank(),
panel.grid.minor.x = element_blank(),
# axis.ticks = element_blank()#,
# text=element_text(family="Open Sans")
)
} else{
t<-t+theme(
panel.grid.major.x = element_line(size=.1, color="gray"),
panel.grid.minor.x = element_line(size=.1, color="lightgray")
)
}
t<-t+theme(plot.title = element_text(
family = "Open Sans",
color = "#554449",
face="bold",
margin=margin(0.1,0,0.1,0,"inch"),
hjust = 0.5))
t<-t+theme(axis.text.x = element_text(
family = "Open Sans"#,
# margin = margin(0,0,0,0)
))
t<-t+theme(axis.text.y = element_text(
family = "Open Sans",
color ="#554449",
margin = margin(0,5,0,0))) +
theme(axis.title.x = element_text(
face = "bold",
color = "#554449",
family = "Open Sans",
# vjust = 7#,This was what was causing the x-axis numbering to overlap with the plot.
margin = margin(5,0,0,5)))
t<-t+theme(axis.title.y = element_text(
face = "bold",
color = "#554449",
family = "Open Sans",
margin = margin(0,15,0,0)))
if(erase_legend_title==TRUE)
t<-t+ theme(legend.title = element_blank())
t<-t+ theme(legend.text = element_text(
family = "Open Sans",
color ="#554449",
margin = margin(2,2,2,2)),
legend.position = 'bottom',
legend.background = element_rect(fill = "white"),
legend.margin=margin(0,0,0,0)
# legend.margin = margin(t=-0.75, unit="cm")
)+
theme(plot.caption = element_text(size=8,
family = "Open Sans",
face = "italic",
vjust= -0.15,
color = "#003366"))
return(t)
}
#' Adds a geom layer to a ggplot object based on user input.
#'
#' @param data A tibble of formatted data for the ggplot
#' @param chart_geom choose from Line Chart or Bar Chart; defaults to Line Chart
#' @param share If TRUE, calculates the share
#' @param x_var The name of fiscal year variable, as string
#' @param y_var The name of variable to plot on y-axis
#' @param color_var The name of the coloration variable, as string
#' @param facet_var The name of facet variable, as string
#' @param second_var The name of the secondary facet variable, as string
#' @param legend If TRUE, includes a legend
#' @param caption If TRUE, includes a source caption
#' @param labels_and_colors A csis360 lookup data.frame with factor information
#' @param column_key A csis360 lookup data.frame with column information
#' @param format If TRUE, summarize the data.frame
#' @param ytextposition If TRUE, add ytextposition to allow for geom_text overlays.
#' @param reverse_color If TRUE, the order of the color variable is flipped
#' @param alpha_var Variable for setting the transparency of bars or line type of lines, coded to be used with year to ate.
#' @param invert_bool Used to create population pyramid or import/export charts, specifies when to show data in the negative space of the y-axis.
#' @param suppress_x_var_newline For categorical x-axis variables, remove any new line from the character string
#'
#'
#'
#' @return A ggplot object including user-specified geom layer
#'
#' @details Intended to handle ggplot settings that depend on user input.
#'Settings that apply universally should be added in server.R.
#'
#'
#' @import ggplot2
#' @import stringr
#' @import scales
#' @import sysfonts
#' @export
build_plot <- function(
data,
chart_geom = "Line Chart",
share = FALSE,
x_var=NULL,
y_var="None", #Name of variable to plot on y-axis
color_var="None", # name of coloration variable, as string
facet_var="None", # name of facet variable, as string
second_var=NULL, # name of facet variable, as string
legend=TRUE, #Include a legend
caption=TRUE, #Include a source caption
labels_and_colors=NULL,
column_key=NULL,
format=FALSE,
ytextposition=FALSE,
first_color_on_bottom=TRUE,
alpha_var=NULL,
invert_bool=NULL,
suppress_x_var_newline=TRUE
){
if(all(!is.null(second_var),facet_var==second_var | second_var=="None")) second_var<-NULL
#To add, check for missing labels and colors
if(format==TRUE)
data <- format_data_for_plot(data=data,
share=share,
fy_var=x_var,
# start_fy=NULL,
# end_fy=NULL,
y_var=y_var,
color_var=color_var,
facet_var=facet_var,
second_var=second_var,
alpha_var=alpha_var,
invert_bool=invert_bool,
labels_and_colors=labels_and_colors,
add_ytextposition=ytextposition,
suppress_x_var_newline=suppress_x_var_newline)
#Nested if because its evaluating the second statement even if the first is false.
if(color_var!="None")
if(all(is.na(data[,color_var]))) stop("Missing color_var after formatting")
if(facet_var!="None")
if(all(is.na(data[,facet_var]))) stop("Missing facet_var after formatting")
if(ytextposition==TRUE & format==FALSE) stop("ytextposition requires format=TRUE")
if(all(is.na(data[,x_var]))) stop("Missing x_var after formatting")
#Legacy bug fix. The sorting in some labels_and_colors is off because display.order was a factor/character, not a number.
if(!is.null(labels_and_colors) & !is.numeric(labels_and_colors$Display.Order)){
labels_and_colors$Display.Order<-as.numeric(as.character(labels_and_colors$Display.Order))
labels_and_colors<-labels_and_colors[order(labels_and_colors$column,labels_and_colors$Display.Order),]
}
#Primarily for bar plots, we want the first in order on the bottom so it is easier to track movements.
if(first_color_on_bottom){
labels_and_colors$Display.Order[labels_and_colors$column==color_var]<-
-1*labels_and_colors$Display.Order[labels_and_colors$column==color_var]
labels_and_colors<-labels_and_colors[order(labels_and_colors$column,labels_and_colors$Display.Order),]
}
data<-as.data.frame(data)
mainplot <- ggplot(data = data)
#Assume 1st row if no x_var provided.
if(is.null(x_var)) x_var<-names(data)[1]
# add a line layer, broken out by color if requested
if(chart_geom == "Line Chart"){
#There must be a better way to do this than 4 branches to cover variable nulls
#Line plots need duplication, otherwise the YTD year is left out because it's only one point.
if(!is.null(alpha_var)){
if(alpha_var=="YTD" & x_var %in% c("Fiscal_Year","Mixed_Year","dFYear")){
max_full_year<-max(data[data$YTD=="Full Year",x_var])
data<-rbind(data,
data[data[,x_var]==max_full_year,] %>%
mutate(YTD="YTD"))
}
#Need to renew the data link here.
if(color_var!="None"){
data$coloralpha<-paste(data[,color_var],data[,alpha_var])
group_var<-"coloralpha"
}
mainplot <- ggplot(data = data)
}
if(color_var == "None"){
if(is.null(alpha_var))
mainplot <- mainplot +
geom_line(aes_q(
x = as.name(x_var),
y = as.name(y_var)))
else{
mainplot <- mainplot +
geom_line(aes_q(
x = as.name(x_var),
y = as.name(y_var),
group = as.name(alpha_var),
linetype= as.name(alpha_var)
))
if(alpha_var=="YTD"){
mainplot<-mainplot+scale_linetype_discrete(breaks=c(1,3),labels=c("Full Year","YTD"))+
theme(axis.text.x = element_text(margin = margin(t = 1, unit = "pt")))
}
}
} else {
if(is.null(alpha_var)){
mainplot <- mainplot +
geom_line(aes_q(
x = as.name(x_var),
y = as.name(y_var),
color = as.name(color_var)
))+
guides(color = guide_legend(override.aes = list(size = 1)))+
theme(legend.key = element_rect(fill = "white"))
}
else{
mainplot <- mainplot +
geom_line(aes_q(
x = as.name(x_var),
y = as.name(y_var),
color = as.name(color_var),
# alpha = as.name(alpha_var)
linetype= as.name(alpha_var)
))+
guides(color = guide_legend(override.aes = list(linewidth = 1)))+
theme(legend.key = element_rect(fill = "white"))
if(alpha_var=="YTD"){
mainplot<-mainplot+scale_linetype_discrete(breaks=c(1,3),labels=c("Full Year","YTD"))+
theme(axis.text.x = element_text(margin = margin(t = 1, unit = "pt")))
}
}
}
}
# add a bar layer, broken out by color if requested
else if(chart_geom == "Bar Chart"){
#There must be a better way to do this
if(color_var == "None"){
if(is.null(alpha_var))
mainplot <- mainplot +
geom_bar(aes_q(
x = as.name(x_var),
y = as.name(y_var)),
stat = "identity")
else{
mainplot <- mainplot +
geom_bar(aes_q(
x = as.name(x_var),
y = as.name(y_var),
alpha = as.name(alpha_var)
),
stat = "identity")
if(alpha_var=="YTD"){
mainplot<-mainplot+scale_alpha_ordinal(labels=c("Full Year","YTD"),range=c(1,0.5))+
theme(axis.text.x = element_text(margin = margin(t = 1, unit = "pt")))
}
}
} else {
if(is.null(alpha_var))
mainplot <- mainplot +
geom_bar(aes_q(
x = as.name(x_var),
y = as.name(y_var),
fill = as.name(color_var)
),
stat = "identity")
else{
mainplot <- mainplot +
geom_bar(aes_q(
x = as.name(x_var),
y = as.name(y_var),
fill = as.name(color_var),
alpha = as.name(alpha_var)
),
stat = "identity")
if(alpha_var=="YTD"){
mainplot<-mainplot+scale_alpha_ordinal(labels=c("Full Year","YTD"),range=c(1,0.5))+
theme(axis.text.x = element_text(margin = margin(t = 1, unit = "pt")))
}
}
}
if(!is.null(invert_bool)){
mainplot<-mainplot+geom_hline(yintercept=0, colour = 'black', size=0.5, linetype='solid')
}
}
else if(chart_geom=="Scatter Plot"){
if(!is.null(second_var)) stop("Have not yet implemented second_var for scatter plot")
if(color_var == "None"){
mainplot<-mainplot+geom_point(
aes_string(x_var,
y_var),
position=position_jitter(width=0.15,height=0.15))
}
else{
label<-subset(labels_and_colors,column==color_var)
label<-label[,colnames(label) %in% c("Label","abbreviation")]
colnames(label)[colnames(label)=="Label"]<-color_var
data<-left_join(data,label)
mainplot<-ggplot(data)+geom_text(
aes_string(x_var,
y_var,
color=color_var,
label="abbreviation"),
position=position_jitter(width=0.2,height=0.2))
}
}
else if (chart_geom=="Histogram"){
if(!is.null(second_var)) stop("Have not yet implemented second_var for histogram")
#If no color, color by what you use to facet
if(color_var=="None" & facet_var!="None") color_var<-facet_var
if(color_var == "None"){
if(is.numeric(data[,colnames(data)==x_var])&
min(data[,colnames(data)==x_var])>=1 & max(data[,colnames(data)==x_var])<=7){
mainplot<-mainplot+geom_histogram(aes_string(x=x_var),
breaks=c(1:7),binwidth=1)
}
else{
mainplot<-mainplot+geom_histogram(aes_string(x=x_var),binwidth=1)
}
}
else{
if(is.numeric(data[,colnames(data)==x_var])&
min(data[,colnames(data)==x_var])>=1 & max(data[,colnames(data)==x_var])<=7){
mainplot<-mainplot+geom_histogram(aes_string(x=x_var,fill=color_var),
breaks=c(1:7))
}
else{
mainplot<-mainplot+geom_histogram(aes_string(x=x_var,fill=color_var),binwidth=1)
}
}
}
else if (chart_geom=="Box and Whiskers"){
#If no color, color by what you use to facet
if(!is.null(second_var)) stop("Have not yet implemented second_var for box and whiskers")
# browser()
if(color_var == "None" | facet_var==color_var){
data$Overall<-"Overall"
if(facet_var!="None"){
mainplot<-ggplot(data)+geom_boxplot(aes_string(y=y_var,
x="Overall",
fill=facet_var
)
)
}
else{
mainplot<-ggplot(data)+geom_boxplot(aes_string(y=y_var,
x="Overall"
)
)
}
} else{
mainplot<-mainplot+geom_boxplot(aes_string(y=y_var,
x=color_var,
fill=color_var)
)
}
}
else stop(paste("Unrecognized chart_geom",chart_geom))
# add faceting if requested, and x-axis labeling
if(facet_var != "None"){
if(chart_geom!="Histogram"){
if(is.null(second_var))
mainplot <- mainplot +
facet_wrap(as.formula(paste0("~ `",facet_var, "`"))) +
theme(strip.background = element_rect(fill = "white"))
else{
mainplot <- mainplot +
facet_grid(as.formula(paste0("`",facet_var, "` ~ `", second_var, "`"))) +
theme(strip.background = element_rect(fill = "white"))
}
# theme(strip.background = element_rect(colour = "#554449", fill = "white", linewidth=0.5),
# panel.border = element_rect(colour = "#554449", fill=NA, linewidth=0.5))
}
else{
mainplot <- mainplot +
facet_wrap(as.formula(paste0("~ `",facet_var, "`")),ncol=1) +
theme(strip.background = element_rect(fill = "white"))
}
}
#For now, assuming numeric var_x means a year. Here we limit the data to only what
# is covered in the year range passed by shiny, if any.
if(chart_geom %in% c("Line Chart","Bar Chart"))
if(is.numeric(data[,x_var])){
start_fy<-min(data[,colnames(data)==x_var])
end_fy<-max(data[,colnames(data)==x_var])
# if(facet_var != "None"){
# mainplot<-mainplot+scale_x_continuous(
# breaks = function(x) {seq(start_fy, end_fy, by = 2)},
# labels = function(x){str_sub(as.character(x), -2, -1)}
# )
# }
# else{
# mainplot <- mainplot +
# scale_x_continuous(
# breaks = function(x){seq(start_fy, end_fy, by = 1)},
# labels = function(x){str_sub(as.character(x), -2, -1)}
# )
# }
}
# add x-axis labeling
if(any(class(data[,x_var])=="Date")){
mainplot<-mainplot+scale_x_date(
# breaks=scales::date_breaks("2 years"),
# c(seq(
# as.numeric(format(min(VAR.long.DF$x.variable),"%Y")),
# as.numeric(format(max(VAR.long.DF$x.variable),"%Y")),
# by=tick.marks)),
labels=scales::date_format("'%y")
# paste("'",format(as.Date(as.character(
# c(seq(
# as.numeric(format(min(VAR.long.DF$x.variable),"%Y")),
# as.numeric(format(max(VAR.long.DF$x.variable),"%Y")),
# by=tick.marks))
# ),"%Y"),"%y"),sep="")
)
}
# add y-axis labeling
if(share == TRUE){
mainplot <- mainplot + scale_y_continuous(labels = scales::percent) +
ylab(label = paste("Share of", y_var))
} else {
# #If any entries are above 10 billion, change the scale to billions
# if(max(shown_data[,y_var])>=1e10)
# mainplot<-mainplot+scale_y_continuous(label = unit_format(unit = "B", scale = 1e-9))
# #If any entries are above 10 million, change the scale to millions
# if(max(shown_data[,y_var])>=1e7)
# mainplot<-mainplot+scale_y_continuous(label = unit_format(unit = "M", scale = 1e-6))
mainplot <- mainplot + scale_y_continuous(
labels = label_units
)
}
if(color_var!="None"){
mainplot<-add_preassigned_scales(
mainplot,
labels_and_colors,
var=color_var
# reverse_color = reverse_color
)
}
if(!is.null(column_key)){
if(chart_geom=="Box and Whiskers")
mainplot<-mainplot+labs(
x=get_label(color_var,column_key),
y=get_label(y_var,column_key,share)
)
else{
mainplot<-mainplot+labs(
x=get_label(x_var,column_key),
y=get_label(y_var,column_key,share)
)
}
if(chart_geom=="Histogram") mainplot<-mainplot+ylab("Count") #No y_var in a histogram.
}
# if(ytextposition){
# mainplot <- mainplot +
# geom_text(aes_string(label=y_var,
# as.formula(paste0("format(round(",
# y_var,
# "3), scientific=FALSE, trim=TRUE, big.mark=",")")),
# x=x_var,
# # format(round(y.variable,3), scientific=FALSE, trim=TRUE, big.mark=",")
# # format(y.variable, digits=1, drop0trailing=TRUE, trim=TRUE, big.mark=",")
# #apply(y.variable,VariableNumericalFormat)
# y="ytextposition"
# ),
# # size=geom.text.size,
# hjust=0.5,
# vjust=0.5
# #,color=color.list This doesn't work yet
# )
# }
# add overall visual settings to the plot
mainplot <- mainplot + get_plot_theme()
#diigtheme1:::diiggraph()
if(legend==FALSE)
mainplot<-mainplot+theme(legend.position = "none")
if(caption==TRUE)
#+labs(y="",
mainplot<-mainplot+labs(caption = "Source: FPDS and CSIS analysis."
)
# return the plot to server.R
return(mainplot)
}
#' @title A legacy function for graphs that allows primary and secondary facets and
#'
#' @param VAR.color.legend.label Label for the fill legend
#' @param VAR.main.label Main title for the graph
#' @param VAR.X.label X-axis label
#' @param VAR.Y.label Y-axis label
#' @param VAR.Coloration A csis360 lookup data.frame with factor information
#' @param VAR.long.DF A data frame of formatted data for the ggplot
#' @param ncol Number of columns for a facet_wrap, doesn't apply if there's a secondary facet
#' @param VAR.x.variable The name of fiscal year variable, as string
#' @param VAR.y.variable The name of variable to plot on y-axis
#' @param VAR.y.series The name of the coloration variable, as string
#' @param VAR.facet.primary The name of the primary facet variable, as string. Defaults to NA.
#' @param VAR.facet.secondary The name of the secondary facet variable, as string. Defaults to NA.
#' @param MovingAverage Hww many units to include in a moving average, defaults to 1, i.e. no average.
#' @param MovingSides How to center the moving average.
#' @param DataLabels Whether to draw data labels on the graph, default=NA or no.
#' @param share If TRUE, calculates the share
#' @param caption If TRUE, includes a source caption, default is false.
#' @param legend If TRUE, includes a legend, default is false.
#' @param geom.text.size Size multipllier for text on the graph.
#'.
#'
#' @return A ggplot object following user-specified parameters.
#'
#' @details This should really be integrated into build_plot
#'
#' @import ggplot2
#' @import dplyr
#' @import tidyverse
#' @import scales
#' @export
LatticePlotWrapper_csis360<-function(VAR.color.legend.label
,VAR.main.label
,VAR.X.label
,VAR.Y.label
,VAR.Coloration
,VAR.long.DF
,VAR.ncol=NA
,VAR.x.variable
,VAR.y.variable
,VAR.y.series
,VAR.facet.primary=NA
,VAR.facet.secondary=NA
,MovingAverage=1
,MovingSides=1
,DataLabels=NA
,caption=FALSE
,legend=FALSE
,geom.text.size=2.5
# ,VAR.override.coloration=NA
){
# debug(PrepareLabelsAndColors)
if("Graph" %in% names(VAR.long.DF)){
VAR.long.DF<-subset(VAR.long.DF, Graph==TRUE)
VAR.long.DF[,VAR.y.series]
}
if(is.na(VAR.y.series)) VAR.y.series<-VAR.facet.primary
#Prepare labels for the category variable
# if(is.na(VAR.override.coloration)){
labels.category.DF<-subset(VAR.Coloration,column==VAR.y.series)
if(nrow(labels.category.DF)==0) stop(paste(VAR.y.series,"is missing from VAR.coloration."))
VAR.long.DF<-as.data.frame(VAR.long.DF)
VAR.long.DF[,VAR.y.series]<-factor(VAR.long.DF[,VAR.y.series],
levels=labels.category.DF$variable)
#Input protection for when the y.series column is entirely na.
if(all(is.na(VAR.long.DF[,VAR.y.series]))) stop(paste(VAR.y.series,"is entirely NA."))
#Ordered Discrete X variables
labels.x.DF<-subset(VAR.Coloration,column==VAR.x.variable)
if(nrow(labels.x.DF)>0){
VAR.long.DF<-as.data.frame(VAR.long.DF)
VAR.long.DF[,VAR.x.variable]<-factor(VAR.long.DF[,VAR.x.variable],
levels=labels.x.DF$variable)
}
# }
# else{
# labels.category.DF<-PrepareLabelsAndColors(VAR.Coloration
# ,VAR.long.DF
# ,VAR.override.coloration
# )
# }
# color.list<-c(labels.category.DF$RGB)
# names(color.list)<-c(labels.category.DF$variable)
old.theme<-theme_set(theme_grey())
if(!is.na(VAR.facet.primary)){
labels.primary.DF<-subset(VAR.Coloration,column==VAR.facet.primary)
if(nrow(labels.primary.DF)>0){
VAR.long.DF[,VAR.facet.primary]<-factor(VAR.long.DF[,VAR.facet.primary],
levels=c(labels.primary.DF$variable),
labels=c(labels.primary.DF$Label),
ordered=TRUE)
}
}
if(is.na(VAR.facet.primary)){
VAR.long.DF<-aggregate(VAR.long.DF[,VAR.y.variable]
, by=list(VAR.long.DF[,VAR.x.variable]
,VAR.long.DF[,VAR.y.series]
)
,FUN = "sum"
,na.rm =TRUE
)
names(VAR.long.DF)<-c("x.variable","category","y.variable")
if(is.numeric(MovingAverage) & MovingAverage>1){
VAR.long.DF$y.raw<-VAR.long.DF$y.variable
VAR.long.DF<-ddply(VAR.long.DF,
.(category),
.fun=TransformFilter,
MovingAverage,
MovingSides
)
VAR.long.DF$y.variable<-VAR.long.DF$MovingAverage
}
VAR.long.DF<-VAR.long.DF %>% dplyr::group_by(x.variable) %>%
dplyr::mutate(
ytextposition=sum(y.variable)-cumsum(y.variable)+0.33*y.variable,
cs=cumsum(y.variable),
rcs=sum(y.variable)-cumsum(y.variable))#.(Fiscal.Year)
}
#Reduce the number of rows by aggregating to one row per unique entry in the VAR.facet.primary column.
else if(is.na(VAR.facet.secondary)){
# VAR.long.DF<-aggregate(VAR.long.DF[,VAR.y.variable]
# , by=list(VAR.long.DF[,VAR.x.variable]
# ,VAR.long.DF[,VAR.y.series]
# ,VAR.long.DF[,VAR.facet.primary]
# )
# ,FUN = "sum"
# ,na.rm =TRUE
# )
VAR.long.DF<-VAR.long.DF %>% group_by(!! as.name(VAR.x.variable),
!! as.name(VAR.y.series),
!! as.name(VAR.facet.primary)) %>%
dplyr::summarise_(
y.variable = lazyeval::interp(~sum(var, na.rm = TRUE), var = as.name(VAR.y.variable)))
colnames(VAR.long.DF)[colnames(VAR.long.DF)==VAR.x.variable]<-"x.variable"
colnames(VAR.long.DF)[colnames(VAR.long.DF)==VAR.y.series]<-"category"
colnames(VAR.long.DF)[colnames(VAR.long.DF)==VAR.facet.primary]<-"primary"
colnames(VAR.long.DF)[colnames(VAR.long.DF)==VAR.y.variable]<-"y.variable"
if(VAR.y.series==VAR.facet.primary){VAR.long.DF$primary<-VAR.long.DF$category}
if(is.numeric(MovingAverage) & MovingAverage>1){
VAR.long.DF$y.raw<-VAR.long.DF$y.variable
VAR.long.DF<-ddply(VAR.long.DF,
.(category,primary),
.fun=TransformFilter,
MovingAverage,
MovingSides
)
VAR.long.DF$y.variable<-VAR.long.DF$MovingAverage
}
#For CumSum to work, make sure factor reordering happens first.
VAR.long.DF<-VAR.long.DF %>%
dplyr::group_by(x.variable,primary) %>%
dplyr::mutate(
ytextposition=sum(y.variable)-cumsum(y.variable)+0.33*y.variable,#.(Fiscal.Year)
# ytextposition=cumsum(y.variable)-0.5*y.variable,
cs=cumsum(y.variable),
rcs=sum(y.variable)-cumsum(y.variable))#.(Fiscal.Year)
}
else{
labels.secondary.DF<-subset(VAR.Coloration,column==VAR.facet.secondary)
if(nrow(labels.secondary.DF)>0){
VAR.long.DF[,VAR.facet.secondary]<-factor(VAR.long.DF[,VAR.facet.secondary]
,levels=c(labels.secondary.DF$variable)
,labels=c(labels.secondary.DF$Label)
,ordered=TRUE)
}
VAR.long.DF<-VAR.long.DF %>% dplyr::group_by(!! as.name(VAR.x.variable),
!! as.name(VAR.y.series),
!! as.name(VAR.facet.primary),
!! as.name(VAR.facet.secondary)) %>%
dplyr::summarise_(
y.variable = lazyeval::interp(~sum(var, na.rm = TRUE), var = as.name(VAR.y.variable)))
# aggregate(VAR.long.DF[,VAR.y.variable]
# , by=list(VAR.long.DF[,VAR.x.variable]
# ,VAR.long.DF[,VAR.y.series]
# ,VAR.long.DF[,VAR.facet.primary]
# ,VAR.long.DF[,VAR.facet.secondary]
# )
# ,FUN = "sum"
# ,na.rm =TRUE
# )
colnames(VAR.long.DF)[colnames(VAR.long.DF)==VAR.x.variable]<-"x.variable"
colnames(VAR.long.DF)[colnames(VAR.long.DF)==VAR.y.series]<-"category"
colnames(VAR.long.DF)[colnames(VAR.long.DF)==VAR.facet.primary]<-"primary"
colnames(VAR.long.DF)[colnames(VAR.long.DF)==VAR.facet.secondary]<-"secondary"
if(is.numeric(MovingAverage) & MovingAverage>1){
VAR.long.DF$y.raw<-VAR.long.DF$y.variable
VAR.long.DF<-ddply(VAR.long.DF,
.(category,primary,secondary),
.fun=TransformFilter,
MovingAverage,
MovingSides
)
VAR.long.DF$y.variable<-VAR.long.DF$MovingAverage
}
#For CumSum to work, make sure factor reordering happens first.
VAR.long.DF<-VAR.long.DF %>%
dplyr::group_by(x.variable,primary,secondary) %>%
dplyr::mutate(
ytextposition=sum(y.variable)-cumsum(y.variable)+0.33*y.variable,#.(Fiscal.Year)
# ytextposition=cumsum(y.variable)-0.5*y.variable,
cs=cumsum(y.variable),
rcs=sum(y.variable)-cumsum(y.variable))#.(Fiscal.Year)
rm(labels.secondary.DF)
}
original<-ggplot(
aes_string(x="x.variable"
, y="y.variable"
, fill="category")
, data=VAR.long.DF
)+ geom_bar(stat="identity")+
xlab(VAR.X.label)+
ylab(VAR.Y.label)+
ggtitle(VAR.main.label, subtitle = NULL)+
get_plot_theme(erase_legend_title = FALSE)
tick.marks<-2
print.figure<-original
if(class(VAR.long.DF$x.variable)=="Date"){
print.figure<-print.figure+scale_x_date(
breaks=scales::date_breaks("2 years"),
# c(seq(
# as.numeric(format(min(VAR.long.DF$x.variable),"%Y")),
# as.numeric(format(max(VAR.long.DF$x.variable),"%Y")),
# by=tick.marks)),
labels=scales::date_format("'%y")
# paste("'",format(as.Date(as.character(
# c(seq(
# as.numeric(format(min(VAR.long.DF$x.variable),"%Y")),
# as.numeric(format(max(VAR.long.DF$x.variable),"%Y")),
# by=tick.marks))
# ),"%Y"),"%y"),sep="")
)
}
# print.figure<-print.figure+geom_bar(
# colour="black",
# stat = "identity",
# property= "identity"
# )
#, labels=c(labels.category.DF$Label) Section labels don't work with facets.
# http://www.cookbook-r.com/Graphs/Facets_(ggplot2)/
print.figure<-print.figure+scale_fill_manual(
VAR.color.legend.label
, values=c(labels.category.DF$RGB)
, limits=c(labels.category.DF$variable)
, labels=c(labels.category.DF$Label)
)
#Don't add numbers at all if there's over 10 facets or 500 rows
if(isTRUE(DataLabels) |
(is.na(DataLabels) &
length(levels(VAR.long.DF$primary))<=10 & nrow(VAR.long.DF)<200
)){
#Drop the labeling detail for crowded graphs.
NumericalDetail<-1
if(nrow(VAR.long.DF)>50){ NumericalDetail<-0 }
print.figure<-print.figure+
geom_text(aes(label=VariableNumericalFormat(y.variable,NumericalDetail)
# format(round(y.variable,3), scientific=FALSE, trim=TRUE, big.mark=",")
# format(y.variable, digits=1, drop0trailing=TRUE, trim=TRUE, big.mark=",")
#apply(y.variable,VariableNumericalFormat)
,y=ytextposition
)
,hjust=0.5
,vjust=0
,size=geom.text.size
#,color=color.list This doesn't work yet
)
}
if(!is.na(VAR.facet.primary)){
if(is.na(VAR.facet.secondary)){
if(!is.na(VAR.ncol)){
print.figure<-print.figure+facet_wrap(~ primary
,ncol=VAR.ncol
# , labeller=Label_Wrap
# , scales="fixed", space="free_y"
)+scale_y_continuous(labels=comma)
}
else{
print.figure<-print.figure+facet_wrap(~ primary
# ,ncol=VAR.ncol
# , labeller=Label_Wrap
# , scales="fixed", space="free_y"
)+scale_y_continuous(labels=comma)
}
# +scale_y_continuous(expand=c(0,0.75)+
# )
}
else{
print.figure<-print.figure+facet_grid(primary ~ secondary
# , labeller=Label_Wrap
, scales="free_y" #The scales actually do stay fixed
, space="free_y"#But only because the space is free
)+scale_y_continuous(expand=c(0,0.75)
,labels=comma
)+theme(strip.text.y=element_text(family="Open Sans",face="bold",angle=0)
)
}
}
#
if(legend==FALSE)
print.figure<-print.figure+theme(legend.position="none")
print.figure<-print.figure
theme(strip.text.x=element_text(face="bold"),
axis.title.y=element_text(angle=90),
legend.title=element_text(hjust=0)
)
# theme(legend.key.width=unit(0.1,"npc"))
# print.figure<-facetAdjust(print.figure,"down")
#If any entries are above 10 billion, change the scale to billions
if(max(VAR.long.DF[,"y.variable"])>=1e10)
print.figure<-print.figure+scale_y_continuous(label = unit_format(unit = "B", scale = 1e-9))
#If any entries are above 10 million, change the scale to millions
else if(max(VAR.long.DF[,"y.variable"])>=1e7)
print.figure<-print.figure+scale_y_continuous(label = unit_format(unit = "M", scale = 1e-6))
if (caption==TRUE)
print.figure<-print.figure+labs(caption = "Source: FPDS; CSIS analysis")
print.figure
}
#' Extract a legend https://stackoverflow.com/questions/43366616/ggplot2-legend-only-in-a-plot
#' Alternate unused approach From https://github.com/tidyverse/ggplot2/wiki/Share-a-legend-between-two-ggplot2-graphs
#'
#' @param filename Output file
#' @param gg A ggplot
#' @param width Output height as per ggsave
#' @param height Output height as per ggsave
#' @param units Output measurement unit as per ggsave
#' @param size New text size
#' @param caption_fraction Ratio of caption to the rest of text
#' @param path for output, defaults to NA for legacy reasons
#' @param second_path for output, typically to save to sharepoint
#' @return Does not return, outptus to file
#'
#' @import ggplot2
#' @export
ggsave600dpi<-function(filename,gg,width,height,units="in",size=12,lineheight=0.13,
caption_fraction=10/12,path=NA,
second_path=NA,...){
if(!is.na(path)) path.file<-file.path(path,filename)
else path.file<-filename
ggsave(path.file, gg+
theme(text=element_text(size=size,lineheight=lineheight),
legend.spacing.x = unit(0.1, 'cm'),
plot.caption = element_text(size=round(size * caption_fraction,0))
),
# font("xy.title", size = 45) +
# font("xy.text", size = 45) +
# font("legend.text", size = 45) +
# theme(text = element_text(size = 45+
width=width, height= height, units=units,dpi=600,...)
if(!is.na(second_path))
ggsave600dpi(filename,gg,width,height,units,size,lineheight,
caption_fraction,path=second_path,...)
}
#' Automatically put an axis in a standardized unit.
#'
#' @param x A column of data
#'
#' @return Data in a standardized form.
#'
#'
#'
#'
#'
#' @import ggplot2
#' @export
label_units<-function(x){
sapply(x, function(y){
if(is.na(y)) return("NA")
y_lab <- "yuge"
if(abs(y) < 1e15) y_lab <- paste0(round(y/1e12), "T")
if(abs(y) < 1e14) y_lab <- paste0(round(y/1e12, 1), "T")
if(abs(y) < 1e13) y_lab <- paste0(round(y/1e12, 2), "T")
if(abs(y) < 1e12) y_lab <- paste0(round(y/1e9), "B")
if(abs(y) < 1e11) y_lab <- paste0(round(y/1e9, 1), "B")
if(abs(y) < 1e10) y_lab <- paste0(round(y/1e9, 2), "B")
if(abs(y) < 1e9) y_lab <- paste0(round(y/1e6), "M")
if(abs(y) < 1e9) y_lab <- paste0(round(y/1e6, 1), "M")
if(abs(y) < 1e7) y_lab <- paste0(round(y/1e6, 2), "M")
if(abs(y) < 1e6) y_lab <- paste0(round(y/1000), "k")
if(abs(y) < 1e5) y_lab <- paste0(round(y/1000, 1), "k")
if(abs(y) < 1e4) y_lab <- paste0(round(y/1000, 2), "k")
if(abs(y) < 1000) ylab <- as.character(round(y))
if(abs(y) < 100) y_lab <- as.character(round(y,1))
if(abs(y) < 10) y_lab <- as.character(round(y,2))
return(y_lab)
})
}
Add the following code to your website.
For more information on customizing the embed code, read Embedding Snippets.