R/plot.R

# - Functions related to plotting

included <- function(x, y) any(y %in% x)

cl_2d_plot <- function(cl, sel) {
  grps <- sapply(cl$inds, included, sel) %>% which()
  sel_grp <- match(x = cl$hulls$grp, table = grps, nomatch = 0) > 0
  pts_lab <- cl$pts[1:min(20, nrow(cl$pts)),]
  sel_pt <- pts_lab$ind %in% sel + 0
  sel_ff <- ifelse(sel_pt, "bold", "plain")
  alpha <- ((cl$hulls$sim + 1) * sel_grp) / 3

  ggplot(cl$hulls, aes_(x = ~x, y = ~y)) +
    geom_polygon(aes_(color = ~grp), fill = NA) +
    geom_polygon(aes_(fill = ~grp, alpha = ~alpha)) +
    geom_point(data = cl$pts) +
    geom_label_repel(aes_(x = ~x, y = ~y, label = ~lab, fontface = ~sel_ff, size = ~sel_ff),
                     pts_lab, point.padding = unit(0.5, "lines"), size = 3.5) +
    scale_alpha_continuous(range = range(alpha)) +
    guides(color = "none", fill = "none", size = "none", alpha = "none") +
    labs(x = "", y = "") +
    theme_default() +
    theme_proj() +
    theme(axis.ticks = element_line(color = "white"),
          axis.text = element_text(color = "white"), legend.position = "bottom")
}

cl_dend_plot <- function(cl, sel) {
  lab_bold <- ifelse(cl$labs %in% sel, "bold", "plain")
  sel_ln <- sapply(cl$lines$inds, included, sel) + 0
  ggplot(cl$lines, aes_(x = ~x1, xend = ~x2, y = ~y1, yend = ~y2,
                        size = ~sel_ln)) +
    geom_segment() +
    scale_x_continuous(breaks = 1:length(cl$labs), labels = names(cl$labs)) +
    scale_y_continuous(labels = function(x) 1 - x) +
    scale_size_continuous(range = c(0.5, 1)) +
    guides(size = "none") +
    labs(x = "", y = "correlation") +
    theme_default() +
    theme_proj() +
    theme(axis.text.x = element_text(angle = -45, hjust = 0, face = lab_bold))
}

pairs_plot <- function(pairs) {
  ggplot(pairs, aes_(x = ~x1, y = ~x2)) +
    geom_point(size = 0.5, alpha = 0.4) +
    geom_smooth(color = "darkred", method = "lm", formula = y ~ x, se = F) +
    facet_grid(n2 ~ n1) +
    scale_x_continuous(breaks = pretty_breaks(3)) +
    scale_y_continuous(breaks = pretty_breaks(3)) +
    labs(x = "", y = "") +
    theme_default() +
    theme_proj() +
    theme(strip.text.x = element_text(angle = 0),
          strip.text.y = element_text(angle = 0),
          axis.text = element_text(size = 10))
}

ppd_plot <- function(ppd, y) {
  ggplot(mapping = aes_(x = ~value)) +
    stat_density(aes_(group = ~key, color = "yrep"),
                 data = ppd, geom = "line", position = "identity",
                 size = 0.25, alpha = 0.3) +
    stat_density(aes_(color = "y"), geom = "line",
                 position = "identity", size = 0.8,
                 data = data.frame(value = y)) +
    scale_color_manual(values = c("black", "#B1BED9")) +
    coord_cartesian(expand = FALSE) +
    theme_default() +
    theme_proj() +
    theme(axis.text.y = element_text(color = "white"),
          axis.ticks.y = element_line(color = "white"),
          axis.title = element_blank(), legend.title = element_blank(),
          legend.position = c(0.9, 0.9))
}

hist_plot <- function(hist) {
  ggplot(hist, aes_(x = ~value)) +
    geom_histogram(color = "black", fill = "#B1BED9", bins = 15) +
    facet_wrap(~ key) +
    labs(y = "") +
    scale_x_continuous(breaks = pretty_breaks(n = 3)) +
    theme_bw() +
    theme_proj() +
    theme(axis.text = element_text(size = 10),
          axis.text.y = element_text(color = "white"),
          axis.ticks.y = element_line(color = "white"))
}

diff_plot <- function(sel_diff, stat, ns) {
  ggplot(tibble(y = sel_diff), aes_(y = ~y, x = "")) +
    stat_ydensity(geom = "violin",
                  draw_quantiles = 0.5, fill = "#B1BED9") +
    labs(x = "", y = paste("Difference in", stat)) +
    theme_default() +
    theme_proj() +
    theme(axis.ticks.x = element_line(color = "white"))
}

perf_plot <- function(stat_arr, nv, stat, sel_size, stat_diff) {
  df <- stat_arr[stat_arr$stat == stat, ]
  df_diff <- df[df$size == sel_size, c("size", "val")]
  if (nrow(df_diff) == 0) df_diff <- tibble(size = 0, val = 0)
  if (!is.null(stat_diff)) df_diff$val <- df_diff$val + stat_diff

  (ggplot(df, aes_(x = ~size, y = ~val)) +
      geom_hline(aes_(yintercept = 0), color = "darkred", linetype = 2) +
      geom_line() +
      geom_pointrange(aes_(ymin = ~lq, ymax = ~uq, fill = '1')) +
      geom_point(aes_(fill = '2'), df_diff,
                 color = "#000000", size = 3, shape = 21) +
      coord_cartesian(xlim = c(1-0.4, nv+0.4), expand = F) +
      scale_x_continuous(breaks = 1:nv) +
      scale_fill_manual(values = c("#000000", "#B1BED9"),
                         labels = c('Suggested', 'Selected'),
                         name = '') +
      labs(y = paste("Difference in", stat, "to the full model"),
           x = "", title = "Performance difference to the full model") +
      theme_default() +
      theme_proj() +
      theme(strip.text = element_blank(),
            axis.text.x = element_blank(),
            plot.background = element_rect(fill = "white", color = "white"),
            legend.position = c(0.9, 0.9))) %>%
    ggplotGrob()
}

gen_heat_bg <- function(pct, col, rows) {
  col_brks <- get_col_brks()
  pct$val_grp <- as.character(sapply(pct$val, function(x) sum(x >= col_brks$breaks)))
  if (identical(rows, 0)) rows <- pct$var[1]
  pct$sel <- (pct$.size == col) & (pct$var %in% rows)
  brks <- sort(unique(as.numeric(pct$val_grp)) + 1)

  (ggplot(pct, aes_(x = ~.size, y = ~var)) +
      geom_tile(aes_(fill = ~val_grp, color = ~sel),
                width = 1, height = 0.9, size = 1) +
      facet_grid(. ~ .size, scales = "free_x", switch = "x") +
      geom_text(aes_(label = ~val, fontface = ~sel+1)) +
      coord_cartesian(expand = FALSE) +
      scale_y_discrete(limits = rev(levels(pct$var))) +
      scale_color_manual(values = c("white", "black")) +
      labs(x = "Model size", y = "",
           title = "Fraction of cv-folds that select the given variable") +
      scale_fill_manual(breaks = brks, values = col_brks$pal[brks]) +
      theme_proj() +
      theme(legend.position = "none",
            axis.text.y = element_text(angle = 45),
            axis.ticks.x = element_blank(),
            axis.text.x = element_blank(),
            panel.background=element_blank())) %>%
    ggplotGrob()
}

gen_dummy_bg <- function(pct, inds) {
  len <- ifelse(identical(inds, 0), 0, length(inds))
  (ggplot(pct, aes_(x = ~.size, y = ~var)) +
      facet_grid(. ~ .size, scales = "free_x", switch = "x") +
      geom_rect(aes_(fill = (~.size == len)),
                xmin=-Inf, xmax=Inf, ymin=-Inf, ymax=Inf) +
      scale_fill_manual(values = c("#F6F6F6", "#B1BED9")) +
      coord_cartesian(expand = FALSE) +
      theme_proj() +
      theme(legend.position = "none",
            axis.ticks.x = element_blank(),
            axis.text.x = element_blank(),
            strip.background = element_blank())) %>%
    ggplotGrob()
}

comb_left <- function(diff, heat, pct, inds) {
  dummy <- gen_dummy_bg(pct, inds)
  heat_sel <- comb_heat(heat, dummy)
  new_width <-  unit.pmax(diff$widths[2:3], heat_sel$widths[2:3]) %>% as.list
  diff$widths[2:3] <- new_width
  heat_sel$widths[2:3] <- new_width
  # New gtable with space for the three plots plus a right-hand margin
  gtable(widths = unit(1, "null"), heights = unit(c(0.4, 0.6), "null")) %>%
    gtable_add_grob(diff, 1, 1) %>% gtable_add_grob(heat_sel, 2, 1)
}

comb_heat <- function(heat, dummy) {
  panels <- grepl(pattern = "panel", dummy$layout$name)
  strips <- grepl(pattern = "strip-b", dummy$layout$name)
  dummy$layout$t[panels] <- dummy$layout$t[panels] + 1
  dummy$layout$b[panels] <- dummy$layout$b[panels] + 1
  new_strips <- gtable_select(dummy, panels | strips)

  gtable_stack(heat, new_strips)
}

gtable_select <- function (x, ...) {
  matches <- c(...)
  x$layout <- x$layout[matches, , drop = FALSE]
  x$grobs <- x$grobs[matches]
  x
}

gtable_stack <- function(g1, g2) {
  g1$grobs <- c(g1$grobs, g2$grobs)
  g1$layout$z <- g1$layout$z - max(g1$layout$z)
  g1$layout$name <- "g2"
  g1$layout <- rbind(g1$layout, g2$layout)
  g1
}

plots_to_grid <- function(w_grid) {
  w_box <- 350
  {
    fluidRow(
      box(plotOutput("clust_dend", height = "auto", width = w_box),
          collapsible = TRUE, width = w_grid,
          title = "Dendogram of the single variable model predictions"),
      box(plotOutput("clust_2d", height = "auto", width = w_box),
          collapsible = TRUE, width = w_grid,
          title = "Scatterplot of the single variable model predictions"),
      box(plotOutput("hist", height = "auto", width = w_box),
          collapsible = TRUE, width = w_grid,
          title = "Histogram of the selected variables"),
      box(plotOutput("pairs", height = "auto", width = w_box),
          collapsible = TRUE, width = w_grid,
          title = "Pairs plot of the selected variables"),
      box(plotOutput("diff", height = "auto", width = w_box),
          collapsible = TRUE, width = w_grid,
          title = "Performance difference to the best model of same size"),
      box(plotOutput("ppd", height = "auto", width = w_box),
          collapsible = TRUE, width = w_grid,
          title = "Predictive distribution of the selected model"))
  }
}

theme_proj <- function() {
  theme(axis.text = element_text(size = 15),
        axis.title = element_text(size = 15),
        strip.text = element_text(size = 15),
        plot.title = element_text(size = 15, face = "bold", hjust = 0.6))
}

get_col_brks <- function() {
  list(breaks = seq(5e-3, 1-5e-3, length.out = 7),
       pal = brewer.pal(11, "RdBu")[3:10])
}
paasim/shinyproj documentation built on May 24, 2019, 5:56 p.m.