R/geom_rbar_interactive.R

In Ashish-Soni08/ggradialbar: A ‘ggplot2’ Radial Bar Chart Extensions for Visualizing High-dimensional Clusters and Their Evolution

# ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
#' Creates an interactive radial barchart which shows a cluster's average feature values

#' @inheritParams geom_rbar
#' @seealso \code{\link{geom_rbar}}
#' @return the interactive radial barchart
#' @name geom_rbar_interactive
#' @export
# ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
geom_rbar_interactive <- function(mapping = NULL,
                                  data = NULL,
                                  stat = "identity",
                                  position = "identity",
                                  ...,
                                  cluster_idx = NULL,
                                  cluster_assignment = NULL,
                                  phase_present = FALSE,
                                  cluster_phase = NULL,
                                  cluster_name = NULL,
                                  cluster_abbrev = NULL,
                                  colour_clusters = NULL,
                                  scale_rng = c(-1, 1) * 1.5,
                                  data_dict = NULL,
                                  delta_threshold = 0.25,
                                  group_names = NULL,
                                  show_group_names = FALSE,
                                  unique_id = NULL,
                                  na.rm = FALSE,
                                  show.legend = NA,
                                  inherit.aes = TRUE
                                  ) {
  ggplot2::layer(
    data = data,
    mapping = mapping,
    stat = stat,
    geom = GeomRbarInteractive,
    position = position,
    show.legend = show.legend,
    inherit.aes = inherit.aes,
    params = list(
      cluster_idx = cluster_idx,
      cluster_assignment = cluster_assignment,
      phase_present = phase_present,
      cluster_phase = cluster_phase,
      cluster_name = cluster_name,
      cluster_abbrev = cluster_abbrev,
      colour_clusters = colour_clusters,
      scale_rng = scale_rng,
      data_dict = data_dict,
      delta_threshold = delta_threshold,
      group_names = group_names,
      show_group_names = show_group_names,
      unique_id = unique_id,
      na.rm = na.rm,
      ...
    )
  )
}

# ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
#' GeomRbarInteractive
#'
#' @rdname ggplot2-ggproto
#' @format NULL
#' @usage NULL
#' @export
# ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
GeomRbarInteractive <- ggplot2::ggproto("GeomRbarInteractive", ggplot2::Geom,
  required_aes = c("x", "y"),
  default_aes = ggplot2::aes(
    fill = "grey60", size = 1.25,
    color_inner_circle = "grey90", standard_error = TRUE
  ),
  setup_params = function(data, params) {
    ggradialbar::GeomRbar$setup_params(data, params)
  },
  setup_data = function(data, params) {
    ggradialbar::GeomRbar$setup_data(data, params)
  },
  draw_group = function(data, params,
                        cluster_idx = NULL,
                        cluster_assignment = NULL,
                        phase_present = FALSE,
                        cluster_phase = NULL,
                        cluster_name = NULL,
                        cluster_abbrev = NULL,
                        colour_clusters = NULL,
                        scale_rng = c(-1, 1) * 1.5,
                        data_dict = NULL,
                        delta_threshold = 0.25,
                        group_names = NULL,
                        show_group_names = FALSE,
                        unique_id = NULL) {

    # q_id is the group rank
    # f_id is the feature id after inserting a space of 2 units between each q_id
    df_plot <- data %>%
      dplyr::group_by(.cluster) %>%
      dplyr::mutate(id = as.double(dplyr::row_number())) %>%
      dplyr::mutate(q_id = dplyr::dense_rank(feature_groups)) %>%
      dplyr::mutate(f_id = dplyr::if_else(q_id == 1, id, id + 2 * (q_id - 1))) %>%
      dplyr::mutate(f_id_adj = dplyr::case_when(
        params$phase_present & .phase == levels(.phase)[1] ~ f_id + 0.15,
        params$phase_present & .phase == levels(.phase)[2] ~ f_id - 0.15,
        TRUE ~ f_id
      )) %>%
      tidyr::complete(f_id = -1:(max(f_id) + 2), fill = list(feature = "", avg = NA_real_)) %>%
      dplyr::ungroup()

    # browser()

    # base_data ----
    # position of group lines and labels
    base_data <- df_plot %>%
      tidyr::drop_na(-.phase) %>%
      dplyr::group_by(feature_groups) %>%
      dplyr::summarize(
        start = min(f_id_adj),
        end = max(f_id_adj),
        title = start + 0.5 * (end - start)
      ) %>%
      dplyr::ungroup() %>%
      dplyr::mutate(hjust = dplyr::case_when(
        dplyr::between(title / max(end), 0.075, 0.425) ~ 1,
        dplyr::between(title / max(end), 0.575, 0.925) ~ 0,
        TRUE ~ 0.5
      )) %>%
      dplyr::mutate(hjust = dplyr::if_else(title / max(end) > 0.9, 0, hjust)) %>%
      # dplyr:: mutate(hjust = case_when(title/max(end) < 0.5 ~ 1,
      #                          TRUE ~ 0)) %>%
      dplyr::mutate(vjust = dplyr::case_when(
        title / max(end) < 0.1 | title / max(end) > 0.9 ~ 1,
        dplyr::between(title / max(end), 0.4, 0.6) ~ 0,
        TRUE ~ 0.5
      ))

    if (isTRUE(params$show_group_names)) {
      base_data <- base_data %>%
        dplyr::mutate(feature_groups = factor(feature_groups, labels = seq_along(levels(feature_groups))))
    }

    # grid_data ----
    # position of grid lines between groups
    grid_data <- df_plot %>%
      # dplyr::filter(.cluster == .cluster[1]) %>%
      dplyr::filter(is.na(id)) %>%
      dplyr::select(f_id) %>%
      dplyr::mutate(diff = f_id - dplyr::lag(f_id, default = f_id[1])) %>%
      dplyr::mutate(g = cumsum(diff > 1) + 1) %>%
      dplyr::select(-diff) %>%
      dplyr::group_by(g) %>%
      dplyr::summarize(start = f_id[1], end = f_id[2]) %>%
      dplyr::ungroup() %>%
      dplyr::mutate(y = list(seq(params$scale_rng[1], params$scale_rng[2], 0.5))) %>%
      tidyr::unnest(y)

    # label_data ----
    # position of feature names
    label_data <- df_plot %>%
      dplyr::mutate(f_id_min = min(f_id) - 2, f_id_max = max(f_id) + 2) %>%
      dplyr::filter(!is.na(f)) %>%
      dplyr::mutate(flag = !is.null(cluster_idx) && params$phase_present) %>%
      dplyr::mutate(y = dplyr::if_else(flag, avg + error, avg)) %>%
      dplyr::group_by(f, f_id_min, f_id_max) %>%
      dplyr::summarize(f_id = mean(f_id), avg = max(avg), y = max(y)) %>%
      dplyr::ungroup() %>%
      dplyr::mutate(rel_pos = f_id / diff(c(f_id_min[1], f_id_max[1]))) %>%
      # dplyr::select(f_id_adj, f, avg) %>%
      # dplyr::mutate(feature_suffix = stringr::str_trunc(feature_suffix, 12)) %>%
      dplyr::mutate(y = dplyr::if_else(y > 0, y, 0)) %>%
      dplyr::mutate(angle = 90 - 360 * (rel_pos + 0.035)) %>%
      # dplyr::mutate(angle = 90 - 360 * ((dplyr::row_number() + 2 - 0.5) / (n() + 4))) %>%
      dplyr::mutate(hjust = dplyr::if_else(angle < -90, 1, 0)) %>%
      dplyr::mutate(angle = dplyr::if_else(angle < -90, angle + 180, angle)) %>%
      tidyr::drop_na() # %>%
    # dplyr::mutate(size = dplyr::if_else(avg >= 0 & (avg * 5 + nchar(f) > 20), 7/.pt, 8/.pt))

    if (!is.null(params$data_dict)) {
      label_data <- label_data %>%
        dplyr::left_join(params$data_dict %>% dplyr::filter(!is.na(label)) %>% dplyr::select(f = label, f_desc = description), by = "f")
    } else {
      label_data <- label_data %>% dplyr::mutate(f_desc = NA_character_)
    }


    # browser()
    if (!is.null(params$cluster_idx)) {
      if (isFALSE(params$phase_present)) {
        cluster_label <- paste0(params$cluster_abbrev, " ", params$cluster_idx, " (n=", sum(df$.cluster == params$cluster_idx), ")")
      } else {
        cluster_label <- paste0(
          params$cluster_abbrev, " ", params$cluster_idx, "\n",
          "n=", dplyr::n_distinct(data_cluster$.id), "/",
          sum(params$cluster_assignment == params$cluster_idx)
        )
      }
      if (!is.null(params$cluster_name)) {
        cluster_label <- paste0(cluster_label, "\n", params$cluster_name)
      }
    }

    x_lim <- c(-2, 2) + range(df_plot$f_id)
    y_lim <- c(
      params$scale_rng[1] - (params$scale_rng[2] - params$scale_rng[1]) * c(0.5, 1)[params$show_group_names + 1],
      params$scale_rng[2] + 1.05
    )


    df_plot <- df_plot %>%
      dplyr::mutate(tooltip = paste0("&mu;=", format(round(avg, 3), nsmall = 3)))


    if (isTRUE(phase_present)) {
      teffect_segments <- df_plot %>%
        dplyr::select(.phase, f, avg, f_id_adj) %>%
        dplyr::filter(!is.na(avg)) %>%
        dplyr::pivot_wider(id_cols = f, names_from = .phase, values_from = c(avg, f_id_adj)) %>%
        dplyr::mutate(effect = avg_A - avg_E) %>%
        dplyr::mutate(effect_category = dplyr::case_when(
          effect > params$delta_threshold ~ 1,
          effect < -params$delta_threshold ~ 3,
          TRUE ~ 2
        )) %>%
        dplyr::mutate(effect_category = factor(effect_category,
          levels = 1:3,
          labels = c(
            "decreased",
            paste0("unchanged ($\\Delta\\leq\\pm$", params$delta_threshold, " SD)"),
            "increased"
          )
        ))

      label_data <- label_data %>% dplyr::left_join(teffect_segments %>% dplyr::select(f, effect_category), by = "f")
    }
    ### Start building up the radar plot

    theme_rbar_interactive <- ggplot2::theme_minimal() +
      ggplot2::theme(
        legend.position = "top",
        axis.text = element_blank(),
        axis.title = element_blank(),
        panel.grid = element_blank(),
        legend.title = element_text(size = 14, face = "bold"),
        legend.text = element_text(size = 14),
        legend.key.size = unit(2, "cm")
      )


    # create ggplot2 object ----
    p <- ggplot2::ggplot(df_plot)
    p <- p + ggplot2::coord_polar()
    p <- p + ggplot2::scale_x_continuous(
      limits = x_lim, expand = c(0, 0),
      breaks = df_plot$f_id, labels = df_plot$f
    )
    p <- p + ggplot2::scale_y_continuous(limits = y_lim)
    p <- p + ggplot2::guides(fill = FALSE)
    p <- p + theme_rbar_interactive
    # draw inner circle ----
    p <- p + ggplot2::annotate("rect",
      xmin = x_lim[1], xmax = x_lim[2],
      ymin = y_lim[1], ymax = params$scale_rng[1] - 0.2,
      color = "transparent", fill = data$color_inner_circle, alpha = 0.2
    )
    if (!is.null(params$cluster_idx)) {
      # central inner label: cluster id and number of instances ----
      p <- p +
        ggplot2::annotate("text",
          x = x_lim[1], y = y_lim[1], # + 0.5,
          label = cluster_label,
          size = 14 / .pt, fontface = "bold", lineheight = 1, vjust = 0.5
        )
      # the actual bars ----
      current_opts <- list(
        data = dplyr::filter(df_plot, !is.na(avg)),
        mapping = ggplot2::aes(x = f_id_adj, y = avg, fill = avg),
        width = 0.7
      )

      # interactive ---
      current_opts$mapping <- ggplot2:::rename_aes(modifyList(
        current_opts$mapping,
        ggplot2::aes(tooltip = tooltip, data_id = f)
      ))
      p <- p + do.call(geom_col_interactive, current_opts)


      p <- p + scale_fill_distiller(
        palette = "RdYlBu",
        limits = c(params$scale_rng[1], params$scale_rng[2]),
        breaks = seq(params$scale_rng[1], params$scale_rng[2], length.out = 7),
        labels = c(
          "-1.5 SD", "-1.0 SD", "-0.5 SD", "Average",
          "+0.5 SD", "+1.0 SD", "+1.5 SD"
        )
      )

      #       p <- p + ggplot2::scale_fill_distiller(
      #         palette = "RdYlBu",
      #         limits = c(scale_rng[1], scale_rng[2]),
      #         breaks = c(scale_rng[1], 0, scale_rng[2]),
      #         labels = c("-1.5 SD", "Average", "+1.5 SD"))
    } else {
      # add radar lines ----
      current_opts <- list(
        mapping = ggplot2::aes(x = f_id_adj, y = avg, group = .cluster, color = .cluster),
        na.rm = TRUE
      )
      # interactive ---
      p <- p + do.call(geom_path, current_opts)

      current_opts <- list(
        mapping = ggplot2::aes(x = f_id_adj, y = avg, color = .cluster),
        size = 1.25,
        na.rm = TRUE
      )

      current_opts$mapping <- ggplot2:::rename_aes(modifyList(
        current_opts$mapping,
        aes(tooltip = tooltip, data_id = f)
      ))

      p <- p + do.call(geom_point_interactive, current_opts)

      p <- p + ggplot2::scale_color_manual(values = params$colour_clusters)
      p <- p + ggplot2::guides(color = ggplot2::guide_legend(title = NULL, ncol = 1))
      p <- p + ggplot2::theme(legend.position = c(1, 1)) # 0.975,0.975
      p <- p + ggplot2::theme(legend.justification = c(1, 1))
    }
    # add some lines between feature groups ----
    p <- p + ggplot2::geom_segment(
      data = grid_data, ggplot2::aes(x = start, xend = end, y = y, yend = y),
      color = "grey", size = 0.3, linetype = 1
    )
    # y axis text ----
    p <- p + ggplot2::annotate("text",
      x = rep(x_lim[2], 7),
      y = seq(params$scale_rng[1], params$scale_rng[2], length.out = 7),
      label = stringr::str_replace(sprintf("%+.1f", seq(params$scale_rng[1], params$scale_rng[2], length.out = 7)), "\\+0.0", "0"),
      color = "black", size = 12 / .pt, hjust = 0.5, angle = 0
    )
    # add 0 line ----
    p <- p + ggplot2::geom_segment(
      data = base_data, ggplot2::aes(
        x = start - 0.5, y = 0,
        xend = end + 0.5, yend = 0
      ),
      color = "black", size = 0.6
    )
    # add baseline ----
    p <- p + ggplot2::geom_segment(
      data = base_data, ggplot2::aes(
        x = start - 0.5, y = -1.7,
        xend = end + 0.5, yend = -1.7
      ),
      color = "black", size = 0.6
    )
    if (isTRUE(params$show_group_names)) {
      # add group ticks ----
      p <- p + ggplot2::geom_segment(data = base_data, ggplot2::aes(
        x = title, xend = title,
        y = -1.8, yend = -1.7
      ), color = "black")
      # add group names ----
      p <- p + ggplot2::geom_text(
        data = base_data, ggplot2::aes(
          x = title, y = params$scale_rng[1] - 0.15 * (params$scale_rng[2] - params$scale_rng[1]),
          label = group, hjust = hjust, vjust = vjust
        ),
        lineheight = 0.85,
        colour = "black", alpha = 0.8, size = 10 / .pt
      )
    }

    if (isTRUE(data$standard_error)) {
      # add standard error as error bar ----
      p <- p + ggplot2::geom_errorbar(ggplot2::aes(x = f_id_adj, ymin = avg - error, ymax = avg + error),
        color = "grey60", size = 0.4, width = 0.5, # alpha = 0.5,
        na.rm = TRUE
      )
      # add small horizontal line on top of error bar
      p <- p + ggplot2::geom_segment(ggplot2::aes(x = f_id_adj - 0.2, y = -sd, xend = f_id_adj + 0.2, yend = -sd),
        color = "grey60", size = 0.4, alpha = 0.5, na.rm = TRUE
      )
    }
    # add labels on top of each bar ----
    current_opts <- list(
      data = label_data,
      mapping = ggplot2::aes(
        x = f_id, y = y + 0.1,
        label = f, hjust = hjust,
        angle = angle
      ), size = 11 / .pt * c(1, 0.8)[1 + params$phase_present],
      alpha = 0.6, show.legend = FALSE
    )
    if (isTRUE(params$phase_present)) {
      current_opts$mapping <- ggplot2:::rename_aes(modifyList(
        current_opts$mapping,
        ggplot2::aes(color = effect_category)
      ))
    }

    # interactive ----
    current_opts$mapping <- ggplot2:::rename_aes(modifyList(
      current_opts$mapping,
      ggplot2::aes(data_id = f, tooltip = f_desc)
    ))

    p <- p + do.call(geom_text_interactive, current_opts)

    p <- p + ggplot2::scale_size_identity()

    if (isTRUE(params$phase_present)) {
      # add treatment effect arrows ----
      p <- p +
        # ggplot2::geom_segment(
        #   data = teffect_segments, ggplot2::aes(
        #     x = f_id_adj_A, xend = f_id_adj_E,
        #     y = avg_A, yend = avg_E, color = effect_category
        #   ),
        #   arrow = ggplot2::arrow(length = unit(c(0.3, 0.2)[1 + interactive], "lines"), type = "closed"),
        #   key_glyph = "segment_custom", size = 0.45
        # ) +
        geom_segment(
          data = teffect_segments, aes(
            x = f_id_adj_A - 0.35, xend = f_id_adj_E + 0.35,
            color = effect_category
          ),
          y = params$scale_rng[1], yend = params$scale_rng[1],
          size = 1
        ) +
        ggplot2::guides(color = ggplot2::guide_legend(title = "Treatment effect")) +
        ggplot2::scale_color_manual(
          values = c("darkgreen", "black", "red"), drop = FALSE,
          labels = unname(latex2exp::TeX(levels(teffect_segments$effect_category)))
        )
    }

    p
  }
)