R/venndir-render-jp.R

#' Render venndir output
#' 
#' Render venndir output
#' 
#' @family venndir core
#' 
#' @inheritParams venndir
#' @param venndir_output `Venndir` output from `venndir()`
#' @param expand_fraction `numeric` value indicating how much to
#'    expand the figure range beyond the default calculated for
#'    the Venn diagram. Values above zero cause the Venn diagram
#'    to be slighly smaller.
#' @param item_cex_factor `numeric` value used to adjust pre-calculated
#'    item fontsizes.
#' @param plot_warning `logical` indicating whether to include a warning
#'    when one or more non-zero overlap counts cannot be displayed
#'    in the figure. Not yet re-implemented for version 0.0.30.900.
#' @param item_degrees `numeric` angle (default 0) in degrees used
#'    to adjust item label display.
#' @param show_segments `logical` (default TRUE) indicating whether to
#'    draw a line segment from the Venn region to any label
#'    positioned outside.
#' @param segment_buffer `numeric` (default -0.1) indicating the depth
#'    inside each Venn region a line segment will be drawn, relevant
#'    only when `show_segments=TRUE`.
#' @param fontfamily `character` font family
#' @param group_labels `logical` (default TRUE) indicating whether to group
#'    label components together, therefore drawing fill and border
#'    around the group instead of each component. In most cases this
#'    setting should be TRUE.
#' @param adjust_center `logical` (default TRUE) used when labels are grouped,
#'    whether the group should be re-centered on the target point.
#'    Try `adjust_center=FALSE` if wide label groups are adjusted
#'    so that the count label is too far left.
#' @param draw_legend `logical` (default TRUE) indicating whether to draw
#'    a legend, calling `venndir_legender()`.
#' @param legend_x `character` passed to `venndir_legender()` to customize
#'    the position of the legend.
#' @param legend_font_cex `numeric` scalar to adjust the legend font size.
#' 
#' @export
render_venndir <- function
(venndir_output=NULL,
 # venn_jp=NULL,
 # label_df=NULL,
 # asp=1,
 # xlim=NULL,
 # ylim=NULL,
 expand_fraction=0,
 # xpd=NA,
 font_cex=1,
 item_cex=NULL,
 item_cex_factor=4,
 plot_warning=TRUE,
 show_labels=NULL,
 show_items=c(NA,
    "none",
    "sign item",
    "item",
    "sign"),
 item_degrees=0,
 max_items=100,
 show_zero=TRUE,
 show_segments=TRUE,
 segment_buffer=-0.10,
 label_preset=c("none"),
 label_style=c("custom",
    "basic",
    "fill",
    "shaded",
    "shaded_box",
    "lite",
    "lite_box"),
 fontfamily="Arial",
 inside_percent_threshold=0,
 item_style=c("text",
    "gridtext"),
 item_buffer=-0.15,
 group_labels=TRUE,
 adjust_center=FALSE,
 draw_legend=TRUE,
 legend_x="bottomright",
 legend_font_cex=1,

 show_label=NA,
 display_counts=TRUE,
 draw_buffer=FALSE,
 ...)
{
   if ("Venndir" %in% class(venndir_output)) {
      venn_jp <- venndir_output@jps;
      label_df <- venndir_output@label_df;
   } else {
      if (length(venndir_output) > 0 && is.list(venndir_output)) {
         if (!any(c("venn_jp", "label_df") %in% names(venndir_output))) {
            stop("List input must contain element names 'venn_jp' or 'label_df'.");
         }
         if (!inherits(venndir_output[["venn_jp"]], "JamPolygon")) {
            stop("Element 'venn_jp' must inherit from 'JamPolygon'.");
         }
         venn_jp <- venndir_output[["venn_jp"]];
         if (!inherits(venndir_output[["label_df"]], "data.frame")) {
            stop("Element 'label_df' must inherit from 'data.frame'.");
         }
         label_df <- venndir_output[["label_df"]];
      }
   }
   show_items <- head(setdiff(label_df$show_items, c(NA, "none")), 1);
   if (length(show_items) == 0) {
      show_items <- NA;
   }
   # jamba::printDebug("show_items: ", show_items);# debug
   # show_items <- head(show_items, 1);
   item_style <- match.arg(item_style);
   
   # Apply label_style
   if (!"custom" %in% label_style) {
      # venndir_output <- venndir_label_style(
      vls <- venndir_label_style(
         list(venn_spdf=venn_jp@polygons, label_df=label_df),
         label_preset=label_preset,
         label_style=label_style,
         show_labels=show_labels,
         inside_percent_threshold=inside_percent_threshold,
         show_zero=show_zero,
         ...);
      venn_jp@polygons <- vls$venn_spdf;
      label_df <- vls$label_df;
   }
   
   # Process existing JamPolygon
   if (length(venn_jp) > 0) {
      # Fill missing attribute colnames with default values
      venn_jp_defaults <- c(
         alpha=venn_jp@polygons$alpha,#jamba::col2alpha(venn_spdf$color),
         lwd=2,
         border=NA
      );
      venn_jp_add <- setdiff(colnames(venn_jp@polygons),
         names(venn_jp_defaults));
      # for (i in venn_jp_add) {
      #    venn_jp@polygons[, i] <- rep(venn_jp_defaults[[i]],
      #       length(venn_jp));
      # }
   }
   
   # Process labels   
   if (length(label_df) > 0) {
      ## Verify label_df contains required columns
      label_df_required <- c(
         "x",
         "y",
         "text");
      if (!all(label_df_required %in% colnames(label_df))) {
         warning(paste0("label_df must contain colnames: ",
            jamba::cPaste(label_df_required)));
      }
      
      # auto-scale item_cex based upon number of items and polygon area
      if (length(item_cex) <= 1) {
         if (length(item_cex) == 1) {
            if (is.na(item_cex)) {
               item_cex <- 1;
            }
         } else {
            item_cex <- 1;
         }
         # recipe to calculate item_cex
         item_cex <- tryCatch({
            poly_rows <- which(!is.na(venn_jp@polygons$venn_counts));
            so_counts <- venn_jp@polygons$venn_counts[poly_rows];
            names(so_counts) <- rownames(venn_jp@polygons)[poly_rows];
            # crude scaling by total number of items
            so_cex <- jamba::noiseFloor(1/sqrt(so_counts) * item_cex_factor,#2.5,
               ceiling=0.9,
               minimum=0.2)
            # update here in case area fails, it will use this crude item_cex
            item_cex <- item_cex * so_cex;
            # area of each polygon
            so_areas <- area_JamPolygon(venn_jp[poly_rows, ]);
            names(so_areas) <- rownames(venn_jp@polygons)[poly_rows];
            # total area of all polygons
            # (not used currently but might be preferred for proportional)
            # so_total_areas <- rgeos::gArea(
            #    rgeos::gSimplify(venn_spdf,
            #       tol=1));
            
            # take median of the larger area polygons
            so_big <- median(so_areas[so_areas / max(so_areas) >= 0.5])
            so_areas_cex <- sqrt(so_areas) / sqrt(so_big);
            
            # weight the effect by number of item labels
            # so that 2 labels would not be scaled as much as 10
            so_areas_wt <- (1 + 0.5) / (so_counts + 0.5)
            so_areas_cex_wt <- so_areas_wt + (1 - so_areas_wt) * so_areas_cex
            # adjust the crude scaling by the relative polygon area
            item_cex <- item_cex * so_areas_cex_wt;
            # for debugging, the data.frame can be printed
            #print(data.frame(so_counts, so_cex, so_areas_cex, so_areas_wt, so_areas_cex_wt, item_cex));
            item_cex;
         }, error=function(e){
            item_cex;
         });
      }
      if (length(item_cex) == 0 || all(is.na(item_cex))) {
         item_cex <- 1;
      }
      
      ## Fill any missing optional colnames with defaults
      label_df_defaults <- list(
         type="main",
         show_label=NA,
         show_items=NA,
         item_degrees=item_degrees,
         vjust=0.5,
         hjust=0.5,
         halign=0.5,
         rot=0,
         color="black",
         fontsize=14,
         item_cex=item_cex,
         border=NA,
         lty=1,
         lwd=1,
         fill=NA,
         padding=3,
         x_offset=0,
         y_offset=0,
         padding_unit="pt",
         r=3,
         segment_buffer=segment_buffer,
         r_unit="pt");
      label_df_add <- setdiff(names(label_df_defaults),
         colnames(label_df));
      for (i in label_df_add) {
         label_df[[i]] <- rep(label_df_defaults[[i]],
            length.out=nrow(label_df));
      }
      
      # replace NA with 0
      label_df$x_offset <- jamba::rmNA(label_df$x_offset,
         naValue=0);
      label_df$y_offset <- jamba::rmNA(label_df$y_offset,
         naValue=0);
      
      # define show_label and show_items for each label_df row
      if (length(show_label) == 0) {
         show_label <- NA;
      }
      if (length(show_items) == 0) {
         show_items <- "none";
      }
      if (length(show_zero) == 0) {
         show_zero <- eval(formals(render_venndir)$show_zero);
      }
      if (length(max_items) == 0) {
         max_items <- Inf;
      }
      # logic:
      # - show_label function argument takes priority over label_df$show_label
      # - show_items function argument takes priority over label_df$show_items
      #
      # - x=NA or y=NA --> show_label=FALSE, show_items=FALSE
      # - show_zero=FALSE, venn_counts=0 --> show_label=FALSE
      # - venn_counts=0 --> show_items=FALSE
      # - show_label=NA, show_items=NA --> show_label=TRUE
      # - show_label=TRUE, show_items=NA --> show_items=FALSE
      # - show_label=FALSE, show_items=NA --> show_items=FALSE
      # - show_label=NA, show_items=TRUE --> show_label=FALSE
      # - show_label=NA, show_items=FALSE --> show_label=TRUE
      # - show_items=TRUE, items column empty or does not exist --> show_items=FALSE
      #
      # TODO:
      # - if x,y + x_offset,y_offset is outside the polygon, allow
      #   show_label=NA --> show_label=TRUE when show_items=TRUE

      if (!"overlap" %in% colnames(label_df)) {
         label_df$overlap <- "inside";
      }
      if (!"count" %in% colnames(label_df)) {
         label_df$count <- "inside";
      }
      show_label <- (label_df$overlap %in% c("outside", "inside") |
            label_df$count %in% c("outside", "inside"));
      # jamba::printDebug("label_df:");print(label_df);

      # warn about hidden non-zero labels
      warn_rows <- (
         (label_df$x %in% NA |
               label_df$y %in% NA) &
            label_df$venn_counts != 0 &
            label_df$type %in% "main");
      #label_df_list <- split(label_df, label_df$overlap_set);
      #warn_by_set <- lapply(label_df_list, function(idf){
      #   (idf$show_label %in% TRUE | !idf$show_items %in% c(FALSE,NA))
      #});
      warning_label <- NULL;
      if (any(warn_rows)) {
         warn_labels <- paste0("'",
            label_df$overlap_set[warn_rows],
            "' (",
            jamba::formatInt(label_df$venn_counts[warn_rows]),
            ")");
         warning_base <- paste0(
            ifelse(sum(warn_rows) > 1, "These overlap counts", "This overlap count"),
            " cannot be displayed: ");
         warning_text <- paste0(warning_base,
            jamba::cPaste(warn_labels, sep=", "));
         warning(warning_text);
         if (TRUE %in% plot_warning) {
            warning_label <- paste0(warning_base,
               "\n",
               jamba::cPaste(warn_labels,
                  sep="; "));
         }
      }
      
      # prepare line segments for labels outside their respective polygons
      g_labels <- NULL;
      segment_df <- NULL;
      if (any(show_label %in% TRUE)) {
         # jamba::printDebug("show_label");
         # jamba::printDebug("table(label_df$overlap):");print(table(label_df$overlap));
         label_outside <- (label_df$overlap %in% "outside" | label_df$count %in% "outside");
         
         # Determine if any offset labels require line segment
         has_offset <- label_outside & (label_df$x_offset != 0 | label_df$y_offset != 0);
         #
         # Todo: Deal with has_offset, for now set to FALSE
         # has_offset <- rep(FALSE, length(has_offset));
         # jamba::printDebug("label_outside:");print(table(label_outside));
         # jamba::printDebug("has_offset:");print(table(has_offset));
         #
         if (any(show_label & has_offset)) {
            use_offset <- (show_label & has_offset);
            offset_sets <- label_df$overlap_set[use_offset];
            # 0.0.20.900 - fix order of preferred polygon labels
            #sp_index <- match(offset_sets, venn_spdf$label);
            # sp_index <- (length(venn_spdf$label) + 1 - 
            #       match(offset_sets, 
            #          rev(venn_spdf$label)));
            sp_index <- (length(venn_jp@polygons$label) + 1 - 
                  match(offset_sets, 
                     rev(venn_jp@polygons$label)));
            segment_buffer <- ifelse(label_df$items %in% "inside",
               label_df$segment_buffer / 2,
               label_df$segment_buffer);
            test_xy <- data.frame(
               check.names=FALSE,
               stringsAsFactors=FALSE,
               x0=label_df$x[use_offset] + label_df$x_offset[use_offset],
               x1=label_df$x[use_offset],
               y0=label_df$y[use_offset] + label_df$y_offset[use_offset],
               y1=label_df$y[use_offset],
               segment_buffer=jamba::rmNA(segment_buffer[use_offset], naValue=-0.1),
               sp_index=sp_index,
               label_color=label_df$color[use_offset],
               label_fill=label_df[use_offset, "fill"],
               label_border=label_df$border[use_offset],
               poly_color=venn_jp@polygons$fill[sp_index],
               poly_border=venn_jp@polygons$border[sp_index]);
            # jamba::printDebug("test_xy:");print(test_xy);# debug
            # sp_list <- lapply(sp_index, function(i){
            #    venn_spdf[i,]});
            jp_list <- lapply(sp_index, function(i){
               venn_jp[i, ]
            });
            # new_xy <- polygon_label_segment(
            # jamba::printDebug("render_venndir(): ", "test_xy:");print(test_xy);# debug
            # jamba::printDebug("render_venndir(): ", "jp_list:");print(jp_list);# debug
            new_xy <- label_segment_JamPolygon(
               x0=test_xy$x0,
               y0=test_xy$y0,
               x1=test_xy$x1,
               y1=test_xy$y1,
               jp=jp_list,
               buffer=test_xy$segment_buffer,
               verbose=FALSE,
               ...);
            # jamba::printDebug("new_xy:");print(new_xy);# debug
            # non-NULL result means we draw a line segment
            if (any(!is.na(new_xy[,1]))) {
               has_segment <- !is.na(new_xy[,1]);
               # priority of colors to use for the line segment
               sc_cols <- c(
                  "label_border",
                  "poly_border",
                  "poly_color",
                  "label_fill",
                  "label_color");
               seg_colors <- apply(test_xy[has_segment, sc_cols, drop=FALSE], 1,
                  function(sc1){
                  sc2 <- jamba::rmNA(sc1);
                  sc2a <- jamba::col2alpha(sc2);
                  sc2 <- sc2[sc2a > 0];
                  head(sc2, 1)
               });
               segment_df <- data.frame(
                  check.names=FALSE,
                  stringsAsFactors=FALSE,
                  x=as.vector(rbind(test_xy$x0[has_segment], new_xy[,1][has_segment])),
                  y=as.vector(rbind(test_xy$y0[has_segment], new_xy[,2][has_segment])),
                  group=rep(venn_jp@polygons$label[test_xy$sp_index[has_segment]], each=2),
                  color=rep(seg_colors, each=2),
                  lwd=rep(jamba::rmNULL(
                     venn_jp@polygons$border.lwd[test_xy$sp_index[has_segment]],
                     nullValue=1), each=2),
                  point_order=c(1, 2)
               );
               # jamba::printDebug("segment_df:");print(segment_df);# debug
            }
         }
         
      }
   }
   
   ## Prepare item labels
   itemlabels_df <- NULL;
   #
   # Todo: Handle item display
   #
   # print(jamba::middle(label_df, 5))
   # print(table(label_df$show_items))
   if (any(!label_df$show_items %in% c("none", NA))) {
      # jamba::printDebug("show_items");
      items_dfs <- subset(label_df, !label_df$show_items %in% c("none", NA));
      # jamba::printDebug("unique(items_dfs$overlap_set): ", unique(items_dfs$overlap_set));
      items_dfs <- split(items_dfs,
         factor(items_dfs$overlap_set,
            levels=unique(items_dfs$overlap_set)));
      # jamba::printDebug("sdim(items_dfs):");print(jamba::sdim(items_dfs));# debug
      # jamba::printDebug("items_dfs:");print(items_dfs);

      #for (items_df1 in items_dfs) {
      itemlabels_list <- lapply(items_dfs, function(items_df1){
         items_list <- items_df1$items;
         items_list <- items_list[lengths(items_list) > 0];
         if (length(items_list) > 0) {
            items <- unname(unlist(jamba::mixedSorts(items_list)));
         } else {
            return(NULL)
         }
         color1 <- rep(items_df1$color, lengths(items_df1$items));
         vis <- which(venn_jp@polygons$label %in% items_df1$overlap_set);
         # vi <- tail(venn_jp@polygons$label %in% items_df1$overlap_set, 1);
         vi <- venn_jp@polygons$label %in% tail(items_df1$overlap_set, 1);
         vdf <- venn_jp@polygons[vi, , drop=FALSE];
         prefixes <- rep(
            gsub(":.+", "", items_df1$text),
            lengths(items_df1$items));
         labels <- NULL;
         # note currently uses the same show_items format per polygon
         # not for each row in items_dfs, so it is not possible to
         # use different show_items format for up-up and down-down within
         # the same polygon
         #show_items_order <- strsplit(items_df1$show_items[1], "[- _.]")[[1]];
         use_show_items <- head(items_df1$item_style, 1);
         # jamba::printDebug("use_show_items:");print(use_show_items);# debug
         # show_items_order <- strsplit(show_items[1], "[- _.]")[[1]];
         show_items_order <- strsplit(use_show_items, "[- _.]")[[1]];
         for (dio in show_items_order) {
            if (grepl("sign", dio)) {
               labels <- paste(labels, prefixes);
            } else if (grepl("item", dio)) {
               labels <- paste(labels, items);
            }
         }
         # jamba::printDebug("unique(items_df1$item_cex):", unique(items_df1$item_cex));
         items_df1$item_cex <- item_cex[as.character(items_df1$overlap_set)];
         labels <- gsub("^[ ]+|[ ]+$", "", labels);
         bg <- jamba::alpha2col(vdf$color, vdf$alpha)
         color <- make_color_contrast(color1,
            y=bg,
            ...);
         
         lpf <- label_fill_JamPolygon(jp=venn_jp[tail(vis, 1), ],
            ref_jp=venn_jp,
            color=color,
            cex=head(items_df1$item_cex, 1),
            draw_points=FALSE,
            labels=labels,
            plot_style="none",
            draw_labels=FALSE,
            degrees=items_df1$item_degrees[1],
            buffer=item_buffer,
            seed=123,
            verbose=TRUE,
            ...);
         # add overlap label to items_df
         lpf$items_df$overlap_set <- head(items_df1$overlap_set, 1);
         # jamba::printDebug("lpf$items_df:");print(lpf$items_df);
         # jamba::printDebug("lpf$items_df:");print(lpf$items_df);
         lpf;
      });
      # combine item label into one data.frame
      itemlabels_df <- jamba::rbindList(lapply(itemlabels_list, function(i1){
         i1$items_df;
      }));
      itemlabels_jp <- NULL;
      # itemlabels_sp <- lapply(itemlabels_list, function(i1){
      #    if (!grepl("Spatial", class(i1$sp_buffer))) {
      #       return(NULL)
      #    }
      #    i1$sp_buffer
      # });
   }
   
   gdf <- NULL;
   if (any(show_label)) {
      # generate data.frame of label coordinates
      show_overlap_outside <- (label_df$overlap %in% "outside" & !is.na(label_df$x))
      show_overlap_inside <- (label_df$overlap %in% "inside" & !is.na(label_df$x))
      show_count_outside <- (label_df$count %in% "outside" & !is.na(label_df$x))
      show_count_inside <- (label_df$count %in% "inside" & !is.na(label_df$x));
      overlap_set <- paste0("**", label_df$overlap_set, "**");
      is_left <- (label_df$type %in% "main") * 1;
      # enhancement to apply fontsize from venn_spdf to main set labels
      label_df$overlap_fontsize <- label_df$fontsize;
      if ("fontsize" %in% colnames(venn_jp@polygons)) {
         setmatch <- match(label_df$overlap_set, venn_jp@polygons$label);
         setmatchupdate <- !is.na(setmatch);
         label_df$overlap_fontsize[setmatchupdate] <- venn_jp@polygons$fontsize[setmatch[setmatchupdate]];
      }
      # gdf is the expanded data.frame of label coordinates
      if (!"vjust_outside" %in% colnames(label_df)) {
         label_df$vjust_outside <- label_df$vjust;
      }
      if (!"hjust_outside" %in% colnames(label_df)) {
         label_df$hjust_outside <- label_df$hjust;
      }
      if (!"vjust_inside" %in% colnames(label_df)) {
         label_df$vjust_inside <- label_df$vjust;
      }
      if (!"hjust_inside" %in% colnames(label_df)) {
         label_df$hjust_inside <- label_df$hjust;
      }
      gdf <- data.frame(
         check.names=FALSE,
         stringsAsFactors=FALSE,
         location=rep(
            c("show_overlap_outside",
               "show_overlap_inside",
               "show_count_outside",
               "show_count_inside"),
            c(sum(show_overlap_outside),
               sum(show_overlap_inside),
               sum(show_count_outside),
               sum(show_count_inside))),
         overlap_set=c(
            label_df$overlap_set[show_overlap_outside],
            label_df$overlap_set[show_overlap_inside],
            label_df$overlap_set[show_count_outside],
            label_df$overlap_set[show_count_inside]),
         text=c(
            overlap_set[show_overlap_outside],
            overlap_set[show_overlap_inside],
            label_df$text[show_count_outside],
            label_df$text[show_count_inside]),
         x=c(
            label_df$x[show_overlap_outside] + label_df$x_offset[show_overlap_outside],
            label_df$x[show_overlap_inside],
            label_df$x[show_count_outside] + label_df$x_offset[show_count_outside],
            label_df$x[show_count_inside]),
         y=c(
            label_df$y[show_overlap_outside] + label_df$y_offset[show_overlap_outside],
            label_df$y[show_overlap_inside],
            label_df$y[show_count_outside] + label_df$y_offset[show_count_outside],
            label_df$y[show_count_inside]),
         vjust=c(
            1 - label_df$vjust_outside[show_overlap_outside],
            1 - label_df$vjust_inside[show_overlap_inside],
            label_df$vjust_outside[show_count_outside],
            label_df$vjust_inside[show_count_inside]),
         hjust=c(
            label_df$hjust_outside[show_overlap_outside],
            label_df$hjust_inside[show_overlap_inside],
            label_df$hjust_outside[show_count_outside],
            label_df$hjust_inside[show_count_inside]),
         halign=c(
            label_df$halign[show_overlap_outside],
            label_df$halign[show_overlap_inside],
            label_df$halign[show_count_outside],
            label_df$halign[show_count_inside]),
         rot=c(
            label_df$rot[show_overlap_outside],
            label_df$rot[show_overlap_inside],
            label_df$rot[show_count_outside],
            label_df$rot[show_count_inside]),
         padding=c(
            label_df$padding[show_overlap_outside],
            label_df$padding[show_overlap_inside],
            label_df$padding[show_count_outside],
            label_df$padding[show_count_inside]) * 1,#font_cex,
         r=c(
            label_df$r[show_overlap_outside],
            label_df$r[show_overlap_inside],
            label_df$r[show_count_outside],
            label_df$r[show_count_inside]),
         r_unit=c(
            label_df$r_unit[show_overlap_outside],
            label_df$r_unit[show_overlap_inside],
            label_df$r_unit[show_count_outside],
            label_df$r_unit[show_count_inside]),
         label_col=c(
            label_df$color[show_overlap_outside],
            label_df$color[show_overlap_inside],
            label_df$color[show_count_outside],
            label_df$color[show_count_inside]),
         fontsize=c(
            label_df$overlap_fontsize[show_overlap_outside],
            label_df$overlap_fontsize[show_overlap_inside],
            label_df$fontsize[show_count_outside],
            label_df$fontsize[show_count_inside]) * font_cex,
         border_col=c(
            label_df$border[show_overlap_outside],
            label_df$border[show_overlap_inside],
            label_df$border[show_count_outside],
            label_df$border[show_count_inside]),
         box_fill=c(
            label_df$fill[show_overlap_outside],
            label_df$fill[show_overlap_inside],
            label_df$fill[show_count_outside],
            label_df$fill[show_count_inside]),
         box_lty=c(
            label_df$lty[show_overlap_outside],
            label_df$lty[show_overlap_inside],
            label_df$lty[show_count_outside],
            label_df$lty[show_count_inside]),
         box_lwd=c(
            label_df$lwd[show_overlap_outside]*2,
            label_df$lwd[show_overlap_inside],
            label_df$lwd[show_count_outside]*2,
            label_df$lwd[show_count_inside]),
         padding_unit=c(
            label_df$padding_unit[show_overlap_outside],
            label_df$padding_unit[show_overlap_inside],
            label_df$padding_unit[show_count_outside],
            label_df$padding_unit[show_count_inside])
      );
      # Update label_col using overlap fill color
      # Todo: Use label_df$fill when not NA
      #
      # get polygon fill color
      omatch <- match(gdf$overlap_set, rownames(venn_jp@polygons));
      omatch_fill <- jamba::alpha2col(venn_jp@polygons$fill[omatch],
         alpha=venn_jp@polygons$alpha[omatch]);
      gdf$bg_fill <- ifelse(grepl("outside", gdf$location),
         "#FFFFFFFF",
         omatch_fill);
      # we need to blend box_fill on top of bg_fill
      # - ensure background alpha is no greater than 1-box_alpha
      box_fill <- jamba::rmNA(naValue="#00000000", gdf$box_fill);
      box_alpha <- jamba::col2alpha(box_fill);
      bg_fill <- jamba::rmNA(naValue="#00000000", gdf$bg_fill);
      max_bg_alpha <- (1 - box_alpha)
      bg_alpha <- jamba::col2alpha(bg_fill);
      bg_alpha_adj <- jamba::noiseFloor(bg_alpha, ceiling=max_bg_alpha)
      bg_fill_adj <- jamba::alpha2col(bg_fill, alpha=bg_alpha_adj);
      canvas_alpha <- max_bg_alpha - bg_alpha_adj;
      canvas_adj <- jamba::alpha2col(rep("white", length(canvas_alpha)), alpha=canvas_alpha)
      todo_color_list <- lapply(seq_along(box_fill), function(jc){
         c(box_fill[jc], bg_fill_adj[jc], canvas_adj[jc])
      })
      gdf$final_fill <- colorjam::blend_colors(todo_color_list);

      # adjust label color to contrast with the polygon fill color
      new_label_col <- make_color_contrast(x=gdf$label_col,
         L_threshold=63,
         y=gdf$final_fill)
         # y=omatch_fill)
      ## update all labels
      gdf$label_col <- new_label_col;
   }
   
   #############################################
   # grid graphics from here on
   jp_xrange <- expand_range(expand_fraction=0.2,
      range(c(
         unlist(venn_jp@polygons$x),
         gdf$x),
         na.rm=TRUE));
   jp_yrange <- expand_range(expand_fraction=0.2,
      range(c(
         unlist(venn_jp@polygons$x),
         gdf$y),
         na.rm=TRUE));
   jp <- plot(venn_jp,
      buffer=expand_fraction + 0.1,
      xlim=jp_xrange,
      ylim=jp_yrange,
      show_labels=FALSE,
      do_pop_viewport=TRUE);
      # do_pop_viewport=FALSE);
   # on.exit(grid::popViewport());
   # adjx,adjy are functions to transform x,y into grid "snpc" coordinates
   adjx <- attr(jp, "adjx");
   adjy <- attr(jp, "adjy");
   jp_viewport <- attr(jp, "viewport");
   
   ############################################
   # Item labels
   # draw using text()
   if (length(itemlabels_df) > 0) {
      #
      # add overlap fill color
      omatch <- match(itemlabels_df$overlap_set, rownames(venn_jp@polygons));
      itemlabels_df$fill <- jamba::alpha2col(venn_jp@polygons$fill[omatch],
         alpha=venn_jp@polygons$alpha[omatch]);
      # adjust label color to contrast with the polygon fill color
      new_item_color <- make_color_contrast(x=itemlabels_df$color,
         L_threshold=63,
         y=itemlabels_df$fill)
      itemlabels_df$color <- new_item_color;
      # jamba::printDebug("middle(itemlabels_df):");print(jamba::middle(itemlabels_df));
      #
      text_grob <- grid::textGrob(
         x=adjx(itemlabels_df$x),
         y=adjy(itemlabels_df$y),
         label=itemlabels_df$text,
         rot=jamba::rmNULL(nullValue=0, itemlabels_df$rot),
         check.overlap=FALSE,
         default.units="snpc",
         gp=grid::gpar(
            col=itemlabels_df$color,
            fontsize=itemlabels_df$fontsize),
         vp=jp_viewport,
         hjust=0.5,
         vjust=0.5);
      # print(jamba::middle(itemlabels_df));
      grid::grid.draw(text_grob);
      # grid::grid.points(
      #    x=adjx(itemlabels_df$x),
      #    y=adjy(itemlabels_df$y),
      #    pch=20);
         # srt is a hack because text() only handles one srt per call
         # srt=-head(itemlabels_df$rot, 1),
         #default.units="native",
         #padding=grid::unit(0, "pt"),
         #r=grid::unit(0, "pt"),
         # adj=c(0.5, 0.5),
         # cex for now is a hack estimate of cex for a given fontsize
         # font could be used for fontfamily but mapping is unclear
         # fontfamily
         #
         # itemlabels_df$border is currently not handled
   }
   
   ############################################
   ## Todo:
   # - draw label line segments (if needed)
   # - draw the warning text label (if needed)
   # - display items (if needed)

   # - display the counts / setlabels
   g_labels <- NULL;
   if (any(show_label)) {
      #
      # g_labels <- gridtext::richtext_grob(
      # jamba::printDebug("gdf:");print(gdf);# debug
      # confirm gdf is not empty - (but why would it be empty?)
      if (nrow(gdf) > 0) {
         g_labels <- gridtext_richtext_grob(
            # default.units="snpc",
            text=gdf$text,
            x=adjx(gdf$x),
            y=adjy(gdf$y),
            default.units="snpc",
            vjust=gdf$vjust,
            hjust=gdf$hjust,
            halign=gdf$halign,
            rot=gdf$rot,
            padding=grid::unit(gdf$padding,
               gdf$padding_unit),
            r=grid::unit(gdf$r,
               gdf$r_unit),
            gp=grid::gpar(
               fontfamily=fontfamily,
               col=gdf$label_col,
               fontsize=gdf$fontsize
            ),
            box_gp=grid::gpar(
               col=if(group_labels){NA}else{gdf$border_col},
               # col=if(group_labels){NA}else{"black"},
               fill=if(group_labels){NA}else{gdf$box_fill},
               lty=gdf$box_lty,
               lwd=gdf$box_lwd)
         );
         # draw grouped label background
         if (TRUE %in% group_labels) {
            grid::pushViewport(attr(jp, "viewport"));
            g_labels <- tryCatch({
               dgg <- draw_gridtext_groups(
                  g_labels=g_labels,
                  gdf=gdf,
                  segment_df=segment_df,
                  adjust_center=adjust_center,
                  do_draw=TRUE,
                  verbose=FALSE)
               dgg$g_labels;
            }, error=function(e){
               print(e);
               g_labels;
            });
            grid::popViewport();
         }
         
         grid::pushViewport(attr(jp, "viewport"))
         grid::grid.draw(g_labels);
         grid::popViewport();
      }
   }
   
   # segments
   if (show_segments && length(segment_df) > 0) {
      # jamba::printDebug("segment_df:");print(segment_df);# debug
      segment_df1 <- subset(segment_df, point_order %in% 1);
      segment_df2 <- subset(segment_df, point_order %in% 2);
      # make unique data.frame to avoid overplotting the same line
      segment_wide <- unique(data.frame(
         check.names=FALSE,
         stringsAsFactors=FALSE,
         x0=segment_df1$x,
         x1=segment_df2$x,
         y0=segment_df1$y,
         y1=segment_df2$y,
         color=segment_df1$color,
         lwd=ifelse(segment_df1$lwd == 0, 1, segment_df1$lwd)));
      # create segments grob
      segments_grob <- grid::segmentsGrob(
         x0=adjx(segment_wide$x0),
         x1=adjx(segment_wide$x1),
         y0=adjy(segment_wide$y0),
         y1=adjy(segment_wide$y1),
         default.units="snpc",
         gp=grid::gpar(col=segment_wide$color,
            lwd=segment_wide$lwd),
         vp=jp_viewport);
      grid::grid.draw(segments_grob);
   }
   
   # venndir legender
   if (TRUE %in% draw_legend) {
      venndir_legender(venndir_out=list(venn_jps=venn_jp),
         x=legend_x,
         font_cex=legend_font_cex,
         ...)
   }
   
   # warning in case not all overlaps can be displayed
   if (length(warning_label) > 0) {
      jamba::printDebug("warning_label exists");
   }
   # debug
   return(list(
      jp=jp,
      label_df=label_df,
      gdf=gdf));

   # return(invisible(list(venn_spdf=venn_spdf,
   #    label_df=label_df,
   #    gdf=gdf,
   #    segment_df=segment_df,
   #    g_labels=g_labels,
   #    vosf=vosf)));
}
jmw86069/venndir documentation built on June 15, 2024, 1:52 p.m.