From bcdd8b9b9be05dfb77574b0bb1594d860cb1dbd8 Mon Sep 17 00:00:00 2001 From: fawda123 Date: Sun, 9 Jun 2024 16:01:25 -0400 Subject: [PATCH] working arrows with tails in show_hmpreport, but function exports messed up --- R/show_hmpreport.R | 151 +++++++++++++++++++++++++++++++++++++++++---- 1 file changed, 139 insertions(+), 12 deletions(-) diff --git a/R/show_hmpreport.R b/R/show_hmpreport.R index 08277750..fa275939 100644 --- a/R/show_hmpreport.R +++ b/R/show_hmpreport.R @@ -162,28 +162,155 @@ show_hmpreport <- function(acres, subtacres, hmptrgs, typ, twocol = FALSE, strat if(!twocol) p <- p + - ggplot2::geom_tile(ggplot2::aes(fill = fillv), color = 'black') + ggplot2::geom_tile(ggplot2::aes(fill = fillv), color = 'black') + + ggplot2::scale_fill_manual( + values = cols, + labels = leglabs, + breaks = leglabs, + na.value = 'white' + ) if(!is.null(text) & !twocol) p <- p + ggplot2::geom_text(data = na.omit(toplo), ggplot2::aes(label = textv), size = text, family = family) - if(twocol) - p <- p + + if(twocol){ + + # Custom arrow grob function up + my_custom_grob_up <- function(x, y, size, color) { + length <- grid::unit(size, "mm") # Fixed length + dx <- length * cos(pi / 4) # x-component of length at 45 degrees + dy <- length * sin(pi / 4) # y-component of length at 45 degrees + + grid::segmentsGrob( + x0 = grid::unit(x, "npc") - dx, y0 = grid::unit(y, "npc") - dy, + x1 = grid::unit(x, "npc") + dx, y1 = grid::unit(y, "npc") + dy, + gp = grid::gpar(col = color, fill = color, lwd = 4), + arrow = grid::arrow(type = "open", length = grid::unit(size, "mm"), angle = 45) + ) + } + + geom_custom_up <- function(mapping = NULL, data = NULL, stat = "identity", + position = "identity", na.rm = FALSE, show.legend = NA, + inherit.aes = TRUE, ...) { + ggplot2::layer( + geom = GeomCustomUp, + mapping = mapping, + data = data, + stat = stat, + position = position, + show.legend = show.legend, + inherit.aes = inherit.aes, + params = list(na.rm = na.rm, ...) + ) + } + + GeomCustomUp <- ggplot2::ggproto("GeomCustom", Geom, + required_aes = c("x", "y"), + default_aes = ggplot2::aes(size = 3, color = "black"), + draw_panel = function(data, panel_scales, coord) { + coords <- coord$transform(data, panel_scales) + grobs <- mapply(my_custom_grob_up, coords$x, coords$y, coords$size, coords$colour, SIMPLIFY = FALSE) + grid::grobTree(do.call(gList, grobs)) + }, + draw_key = draw_key_point + ) + + # Custom arrow grob function down + my_custom_grob_down <- function(x, y, size, color) { + length <- grid::unit(size, "mm") # Fixed length + dx <- length * cos(pi / 4) # x-component of length at 45 degrees + dy <- length * sin(pi / 4) # y-component of length at 45 degrees + + grid::segmentsGrob( + x0 = grid::unit(x, "npc") - dx, y0 = grid::unit(y, "npc") + dy, + x1 = grid::unit(x, "npc") + dx, y1 = grid::unit(y, "npc") - dy, + gp = grid::gpar(col = color, fill = color, lwd = 4), + arrow = grid::arrow(type = "open", length = grid::unit(size, "mm"), angle = 45) + ) + } + + geom_custom_down <- function(mapping = NULL, data = NULL, stat = "identity", + position = "identity", na.rm = FALSE, show.legend = NA, + inherit.aes = TRUE, ...) { + ggplot2::layer( + geom = GeomCustomDown, + mapping = mapping, + data = data, + stat = stat, + position = position, + show.legend = show.legend, + inherit.aes = inherit.aes, + params = list(na.rm = na.rm, ...) + ) + } + + GeomCustomDown <- ggplot2::ggproto("GeomCustom", Geom, + required_aes = c("x", "y"), + default_aes = ggplot2::aes(size = 3, color = "black"), + draw_panel = function(data, panel_scales, coord) { + coords <- coord$transform(data, panel_scales) + grobs <- mapply(my_custom_grob_down, coords$x, coords$y, coords$size, coords$colour, SIMPLIFY = FALSE) + grid::grobTree(do.call(gList, grobs)) + }, + draw_key = draw_key_point + ) + + # legend drawing function up arrow + draw_key_up <- function(data, params, size){ + params$arrow$length <- grid::unit(0.35, 'cm') + grid::segmentsGrob(0.1, 0.1, 0.9, 0.9, + gp = grid::gpar(col = 'black', fill = 'black', lwd = 2, lineend = "butt"), + arrow = params$arrow + ) + } + + # legend drawing function down arrow + draw_key_down<- function(data, params, size){ + params$arrow$length <- grid::unit(0.35, 'cm') + grid::segmentsGrob(0.1, 0.9, 0.9, 0.1, + gp = grid::gpar(col = 'black', fill = 'black', lwd = 2, lineend = "butt"), + arrow = params$arrow + ) + } + + toplo <- toplo %>% + dplyr::mutate( + z = rep('Trending above', nrow(.)), + v = rep('Trending below', nrow(.)) + ) %>% + dplyr::filter(!is.na(fillv)) + + p <- p + ggplot2::geom_tile(fill = NA, color = NA) + - ggplot2::geom_point(data = na.omit(toplo), ggplot2::aes(shape = shapv, fill = fillv), color = 'black', size = 5) + - ggplot2::scale_shape_manual(values = c('Trending below' = 25, 'Trending above' = 24)) + - ggplot2::guides(fill = ggplot2::guide_legend(override.aes = list(color = cols, shape = 15, size = 5))) + ggplot2::geom_point(data = toplo, ggplot2::aes(x = metric, y = yearfac, color = fillv), alpha = 0) + + geom_custom_up(data = toplo[toplo$shapv == 'Trending above', ], ggplot2::aes(x = metric, y = yearfac, color = fillv), show.legend = F) + + geom_custom_down(data = toplo[toplo$shapv == 'Trending below', ], ggplot2::aes(x = metric, y = yearfac, color = fillv), show.legend = F) + + ggplot2::scale_colour_manual(values = cols) + + ggplot2::guides(color = ggplot2::guide_legend(override.aes = list(alpha = 1, shape = 15, size = 6))) + + ggplot2::geom_segment(data = toplo, + ggplot2::aes(x = metric, xend = metric, y = yearfac, yend = yearfac, linetype = z), + arrow = grid::arrow(length = grid::unit(0.25, 'cm'), type = 'open', angle = 45), + size = 0.7, alpha = 0, + key_glyph = "up" + ) + + ggplot2::geom_segment(data = toplo, + ggplot2::aes(x = metric, xend = metric, y = yearfac, yend = yearfac, linetype = v), + arrow = grid::arrow(length = grid::unit(0.25, 'cm'), type = 'open', angle = 45), + size = 0.7, alpha = 0, + key_glyph = "down" + ) + + labs( + linetype = NULL, + color = NULL, + fill = NULL + ) + + } p <- p + ggplot2::scale_y_discrete(expand = c(0, 0)) + ggplot2::scale_x_discrete(expand = c(0, 0), position = 'top') + - ggplot2::scale_fill_manual( - values = cols, - labels = leglabs, - breaks = leglabs, - na.value = 'white' - ) + thm + ggplot2::geom_vline(xintercept = xvec, linewidth = 1) + ggplot2::labs(