diff --git a/dev/loghistplot.R b/dev/loghistplot.R index fbb7deb..68df315 100644 --- a/dev/loghistplot.R +++ b/dev/loghistplot.R @@ -33,22 +33,15 @@ # TODO: Get variable labels from data (if labeled) or args xlab=, ylab= # TODO: Combine these functions in a more general way. An argument, `marginal = c("hist", "points")` -# FIXME: I get errors / warning with the test case: -# > source("C:/R/projects/vcdExtra/dev/loghistplot.R") -# > data(Donner, package = "vcdExtra") -# > loghistplot(Donner[,c("age","survived")]) -# Loading required package: ggplot2 -# Loading required package: gridExtra -# Error in opts(panel.grid.major = theme_blank(), panel.grid.minor = theme_blank(), : -# could not find function "opts" -# In addition: Warning message: -# In geom_smooth(method = "glm", family = binomial, se = TRUE, colour = "black", : -# Ignoring unknown parameters: `family` - # Define the function -loghistplot <- function(data) { +loghistplot <- function(data, bins = 30) { - require(ggplot2); require(gridExtra) # load packages + require(ggplot2); require(gridExtra); require(grid) # load packages + + if (length(bins) != 1L || !is.numeric(bins) || is.na(bins) || + !is.finite(bins) || bins < 1 || bins != floor(bins)) { + stop("`bins` must be one positive whole number.", call. = FALSE) + } names(data) <- c('x','y') # rename columns @@ -59,46 +52,93 @@ loghistplot <- function(data) { max_y <- max(data$y) # get bin numbers - bin_no <- max(hist(data$x)$counts) + 5 + bin_width <- (max(data$x) - min(data$x)) / bins + hist_breaks <- seq(min(data$x), max(data$x), length.out = bins + 1) + hist_counts <- lapply(unique(data$y), function(y) { + hist(data$x[data$y == y], breaks = hist_breaks, right = FALSE, + include.lowest = TRUE, plot = FALSE)$counts + }) + max_count <- max(unlist(hist_counts)) + bin_no <- 4 * max_count + + count_ticks <- pretty(c(0, max_count)) + count_ticks <- count_ticks[count_ticks >= 0 & count_ticks <= max_count] + count_positions <- sort(c(count_ticks / bin_no, + 1 - count_ticks / bin_no)) + count_labels <- round(bin_no * pmin(count_positions, + 1 - count_positions)) # create plots a <- ggplot(data, aes(x = x, y = y)) + theme_bw(base_size=16) + - geom_smooth(method = "glm", family = binomial, se = TRUE, - colour='black', linewidth=1.5, alpha = 0.3) + - # scale_y_continuous(limits=c(0,1), breaks=c(0,1)) + - scale_x_continuous(limits=c(min_x,max_x)) + - opts(panel.grid.major = theme_blank(), - panel.grid.minor=theme_blank(), - panel.background = theme_blank()) + + geom_smooth(method = "glm", method.args = list(family = "binomial"), + se = TRUE, colour = 'black', linewidth = 1.5, alpha = 0.3) + + scale_y_continuous( + limits = c(0, 1), + breaks = seq(0, 1, by = 0.2), + expand = expansion(mult = 0), + sec.axis = dup_axis( + breaks = count_positions, + labels = count_labels, + name = "Count" + ) + ) + + coord_cartesian(xlim = c(min_x, max_x)) + + theme(panel.grid.major = element_blank(), + panel.grid.minor = element_blank(), + panel.background = element_blank(), + plot.background = element_blank()) + labs(y = "Probability\n", x = "\nYour X Variable") b <- ggplot(data[data$y == unique(data$y)[1], ], aes(x = x)) + theme_bw(base_size=16) + - geom_histogram(fill = "grey") + - scale_y_continuous(limits=c(0,bin_no)) + - scale_x_continuous(limits=c(min_x,max_x)) + - opts(panel.grid.major = theme_blank(), - panel.grid.minor=theme_blank(), - axis.text.y = theme_blank(), - axis.text.x = theme_blank(), - axis.ticks = theme_blank(), - panel.border = theme_blank(), - panel.background = theme_blank()) + - labs(y='\n', x='\n') + geom_histogram(fill = "grey", binwidth = bin_width, + boundary = min(data$x), closed = "left") + + scale_y_continuous( + limits = c(0, bin_no), + labels = function(z) rep("0.0", length(z)), + expand = expansion(mult = 0), + sec.axis = dup_axis( + breaks = count_ticks, + labels = count_ticks, + name = "Count" + ) + ) + + coord_cartesian(xlim = c(min_x, max_x)) + + theme(panel.grid.major = element_blank(), + panel.grid.minor = element_blank(), + axis.text = element_text(colour = "transparent"), + axis.ticks = element_line(colour = "transparent"), + axis.title = element_text(colour = "transparent"), + panel.border = element_blank(), + panel.background = element_blank(), + plot.background = element_blank()) + + labs(y = "Probability\n", x = "\nYour X Variable") c <- ggplot(data[data$y == unique(data$y)[2], ], aes(x = x)) + theme_bw(base_size=16) + - geom_histogram(fill = "grey") + - scale_y_continuous(trans='reverse') + - scale_y_continuous(trans='reverse', limits=c(bin_no,0)) + - scale_x_continuous(limits=c(min_x,max_x)) + - opts(panel.grid.major = theme_blank(),panel.grid.minor=theme_blank(), - axis.text.y = theme_blank(), axis.text.x = theme_blank(), - axis.ticks = theme_blank(), - panel.border = theme_blank(), - panel.background = theme_blank()) + - labs(y='\n', x='\n') + geom_histogram(fill = "grey", binwidth = bin_width, + boundary = min(data$x), closed = "left") + + scale_y_reverse( + limits = c(bin_no, 0), + labels = function(z) rep("0.0", length(z)), + expand = expansion(mult = 0), + sec.axis = dup_axis( + breaks = count_ticks, + labels = count_ticks, + name = "Count" + ) + ) + + coord_cartesian(xlim = c(min_x, max_x)) + + theme(panel.grid.major = element_blank(), + panel.grid.minor = element_blank(), + axis.text = element_text(colour = "transparent"), + axis.ticks = element_line(colour = "transparent"), + axis.title = element_text(colour = "transparent"), + panel.border = element_blank(), + panel.background = element_blank(), + plot.background = element_blank()) + + labs(y = "Probability\n", x = "\nYour X Variable") grid.newpage() pushViewport(viewport(layout = grid.layout(1,1))) @@ -129,12 +169,13 @@ logpointplot <- function(data) { ggplot(data, aes(x = x, y = y)) + theme_bw(base_size=16) + geom_point(alpha = 0.5, position = position_jitter(w=0, h=0.02)) + - geom_smooth(method = "glm", family = "binomial", se = TRUE, - colour='black', size=1.5, alpha = 0.3) + + geom_smooth(method = "glm", method.args = list(family = "binomial"), + se = TRUE, colour='black', size=1.5, alpha = 0.3) + scale_x_continuous(limits=c(min_x,max_x)) + - opts(panel.grid.major = theme_blank(), - panel.grid.minor=theme_blank(), - panel.background = theme_blank()) + + theme(panel.grid.major = element_blank(), + panel.grid.minor = element_blank(), + panel.background = element_blank(), + plot.background = element_blank()) + labs(y = "Probability\n", x = "\nYour X Variable") }