#' Some Graphics functions
#'
#' Some graphics functions for working with Economic Models.
#'
#' @import ggplot2
#' @import mosaic
#' @import scales
#' @export
tri2x <- function(x,y,z) {
y * 1 + z * 0.5 # + x * 0
}
#' @export
tri2y <- function(x,y,z) {
z * 1 # + x * 0 + y * 0
}
#' @export
tri_theme <- function(base_size=12, base_family = "", base_theme=theme_bw) {
xy_theme_old(base_size = base_size, base_family = base_family) %+replace%
theme(panel.border = element_blank(),
axis.line = element_blank(),
axis.text = element_blank(),
axis.ticks = element_blank(),
axis.title = element_blank(),
panel.grid.major = element_blank(),
panel.grid.minor = element_blank(),
plot.background = element_blank(),
strip.background = element_rect(fill = NA, colour = xy_theme_old()$axis.text$colour)
)
}
#' @export
xy_theme_old <- function(base_size=12, base_family = "", base_theme=theme_bw, label_colour="gray50") {
base_theme(base_size = base_size, base_family = base_family) %+replace%
theme(# panel.border = element_blank(),
# panel.grid.major = element_blank(),
panel.grid.minor = element_blank(),
plot.background = element_blank(),
strip.text = element_text(colour=label_colour, size=.8 * base_size),
strip.background = element_rect(fill = NA, colour = NA),
legend.background = element_rect(fill=NA, colour=NA),
legend.key= element_rect(fill=NA, colour=NA),
legend.text=element_text(colour=label_colour),
axis.text = element_text(colour=label_colour, size=.8 * base_size),
axis.ticks = element_blank(),
axis.title = element_text(colour=label_colour, size=base_size)
)
}
#' @export
xy_theme <- function(base_size=12, base_family = "", base_theme=theme_bw, label_colour="gray50") {
# See https://github.com/infotroph/ggplot-ticks if we want to mirror ticks on top and right.
base_theme(base_size = base_size, base_family = base_family) %+replace%
theme(# panel.border = element_blank(),
panel.grid.major = element_blank(), # No grid lines
panel.grid.minor = element_blank(), # No grid lines
plot.background = element_blank(),
strip.text = element_text(colour=label_colour, size=0.8 * base_size),
strip.background = element_rect(fill = NA, colour = NA),
legend.title = element_text(colour = label_colour),
legend.background = element_rect(fill=NA, colour=NA),
legend.key = element_rect(fill=NA, colour=NA),
legend.text = element_text(colour=label_colour),
axis.text = element_text(colour=label_colour, size=0.8 * base_size),
axis.ticks = element_line(colour=label_colour, size=0.2), # Sets thickness of ticks
axis.title = element_text(colour=label_colour, size=base_size),
# Put ticks inside graph and adjust location of axis labels appropriately.
axis.ticks.length = unit(-0.3*base_size, "pt"),
axis.text.x = element_text(margin = margin(t = 0.8*base_size, unit = "pt")),
axis.text.y = element_text(margin = margin(r = 0.8*base_size, unit = "pt"), hjust = 1) # Right justify
)
}
# #' @export
# triPlot <- function(data, mapping, labels=c("alpha[1]", "alpha[2]", "alpha[3]"),
# parse=TRUE, grid_lines=4, aes_string = NULL,
# geom=geom_point, ...) {
# if (!is.null(aes_string))
# stop( "aes_string has been deprecated.",
# "Assign the output of aes() to mapping instead.")
#
# h <- seq(0, 1, by=1/grid_lines)
# points <- data.frame( h=h )
#
# requiredNames <- c("x", "y", "z")
# w <- which (! requiredNames %in% names(mapping))
# if (length(w) > 0)
# stop("triPlot requires the following aesthetics: ", paste(requiredNames[w], collapse=","))
#
# xyz_mapping <-
# list(
# x = bquote(tri2x(.(mapping$x), .(mapping$y), .(mapping$z))),
# y = bquote(tri2y(.(mapping$x), .(mapping$y), .(mapping$z)))
# )
# class(xyz_mapping) <- "uneval"
# mapping["z"] <- NULL
#
# mapping <- modifyList(mapping, xyz_mapping)
#
# p <- ggplot(data = data)
#
# q <- p +
# expand_limits( x=c(-.2,1.2), y=c(-.05,1.25) ) +
# tri_theme() +
# geom_segment(aes(x=tri2x(h,0,1-h), xend = tri2x(h, 1-h, 0),
# y=tri2y(h,0,1-h), yend = tri2y(h, 1-h, 0)),
# data=points, color=xy_theme_old()$panel.grid.major$colour) +
# geom_segment(aes(x=tri2x(0,h,1-h), xend = tri2x(1-h, h, 0),
# y=tri2y(0,h,1-h), yend = tri2y(1-h, h, 0)),
# data=points, color=xy_theme_old()$panel.grid.major$colour) +
# geom_segment(aes(x=tri2x(0,1-h,h), xend = tri2x(1-h, 0, h),
# y=tri2y(0,1-h,h), yend = tri2y(1-h, 0, h)),
# data=points, color=xy_theme_old()$panel.grid.major$colour) +
# geom_text(aes(label=label, x=x, y=y, hjust=hj, vjust=vj),
# color=xy_theme_old()$axis.title$colour,
# size=4,
# data=data.frame(label=rep(labels, length.out=3),
# x=c(.5,-.02,1.02)[c(2, 3, 1)],
# y=c(1.02,0,0)[c(2, 3, 1)],
# hj = c(.5,1,0)[ c(2, 3, 1)],
# vj = c(0,0.5,0.5)[c(2, 3, 1)]
# ),
# parse=parse)
# q + do.call( geom, c(list(mapping=mapping), list(...)) )
# }
#' @export
Log <- function(x, ...) {
if (is.null(x) ) {
return(rep(1,length(x)))
}
log(x, ...)
}
#' @export
sigma_trans <- function(base = exp(1)) {
trans <- function(x) pnorm(log(x, base))
inv <- function(x) base ^ qnorm( x )
trans_new(paste0("sigma-", format(base)),
transform = function(x) {
# print(match.call())
pnorm(Log(x, base))
},
inverse = function(x) base ^ qnorm( x ),
breaks=function(x) { return( base^qnorm((seq(0,1, length.out=5) ))) },
domain = c(0, Inf))
}
#' @export
sigma2_trans <- function() {
trans_new("sigma2",
transform = function(x) sign(x) * pnorm(log(abs(x))),
inverse = function(x) sign(x) * exp(qnorm(abs(x))),
domain = c(0, Inf)
)
}
# #' @export
# standardTriPlot <- function(
# data,
# mapping = aes(),
# grid_lines=5,
# orig_color = "gray70",
# labels=c("alpha[3]", "alpha[1]", "alpha[2]"),
# size=1.0,
# alpha=0.2,
# facet_formula = country ~ nest )
# {
#
# p <- triPlot(subset(data, method!="orig"),
# mapping = modifyList(aes(x=alpha_1, y=alpha_2, z=alpha_3), mapping),
# labels=labels,
# grid_lines=grid_lines,
# size=size, alpha=alpha ) +
# geom_point(data=subset(data, method=="orig"),
# aes(x = tri2x(alpha_1, alpha_2, alpha_3),
# y = tri2y(alpha_1, alpha_2, alpha_3)),
# color=orig_color, alpha=1, size=4, shape=10)
# if ( !is.null(facet_formula) ) {
# if ( length(facet_formula)==2 ) {
# p <- p + facet_wrap( facet_formula )
# } else {
# p <- p + facet_grid( facet_formula )
# }
# }
# return(p)
# # scale_colour_gradient(expression(lambda), high="navy", low="skyblue")
# }
#' @export
standardScatterPlot <- function(data, mapping=aes(), orig_color="gray70", size=2.0, alpha=0.4,
facet_formula = countryAbbrev ~ nest) {
p <- ggplot( data=subset(data, method != "orig"), mapping )
p <- p + geom_point(size=size, alpha=alpha)
# p <- p + geom_hex( bins=60)
p <- p + geom_point(data=subset(data, method=="orig"),
color=orig_color, size=4, shape=10 )
if ( !is.null(facet_formula) ) {
if ( length(facet_formula)==2 ) {
p <- p + facet_wrap( facet_formula )
} else {
p <- p + facet_grid( facet_formula )
}
}
if ("color" %in% mapping || "colour" %in% mapping) {
p <- p + scale_colour_gradient(expression(lambda), high="navy", low="skyblue")
}
p + xy_theme()
}
#' @export
spaghettiPlot <- function(data,
variables = union(all.vars(facet_formula), "Year"),
geom_actual = geom_line,
facet_formula = Country ~ nestStr,
alpha=0.15,
level = 1, ...){
alph = .5 * (1 - level)
data$alph = alph
variables <- intersect( variables, names(data) )
seData <- plyr::ddply( subset(data, resampled), variables, plyr::summarise,
n = length(iGDP.hat),
lower = quantile(iGDP.hat, alph[1]),
upper = quantile(iGDP.hat, 1-alph[1]),
center = iGDP.hat[1]
)
graph <- ggplot(aes(y=iGDP, x=Year),
data=subset(data, !resampled))
graph <- graph +
geom_smooth(aes(x=Year, ymin=lower, ymax=upper, y=center),
data=seData,
col=NA, fill="gray10",
lty=1, size=.5, stat="identity")
graph <- graph +
geom_line( aes(x=Year, y=iGDP),
data = subset(data, !resampled),
color="black", size=.4, shape=1, alpha=1.0)
graph <- graph +
geom_line(aes(x=Year, y=iGDP.hat),
data=subset(data, !resampled),
color="gray90", size=.4, shape=1, alpha=1.0)
if (!is.null( facet_formula ) ) {
if (length(facet_formula) == 2) {
graph <- graph + facet_wrap( facet_formula, scales="free_y" )
} else {
graph <- graph + facet_grid( facet_formula, scales="free_y" )
}
}
graph <- graph + xlab("")
graph <- graph + xy_theme()
return(graph)
}
#' Create graph of historical data.
#'
#' @param data a data frame containing data to be plotted.
#' @param mapping the argument to the geom_line function.
#' Use for setting, x, y, color, among other things: mapping=aes(x=scale, y=lambda, color=country)
#' @param facet_formula a formula of the form `y ~ x` where `y` is the varible to facet in
#' the y direction
#' and `x` is the variable to facet in the x direction.
#' @param line_types is a vector of linetype identifiers to be applied as the line types for the `group`s.
#' @details This function returns a figure with facets specified by `facet_formula`
#' and various lines specified by `line_formula`.
#' You may have to use the package `reshape2` to "melt" your data to the correct form before passing
#' it to this function.
#' @export
historicalPlot <- function(data, mapping, facet_formula, line_types){
graph <- ggplot(data, mapping=mapping) +
geom_line(mapping) +
facet_grid( facet_formula, scales="free_y" ) +
scale_linetype_manual(name="", values=line_types) +
xy_theme()
return(graph)
}
Add the following code to your website.
For more information on customizing the embed code, read Embedding Snippets.