R/drawForestplotObject.R

In forestplot: Advanced Forest Plot Using 'grid' Graphics

#' @noRd
drawForestplotObject <- function(obj) {
  ##################
  # Build the plot #
  ##################
  labels <- prGetLabelsList(
    labels = obj$labels,
    align = obj$align,
    is.summary = obj$is.summary,
    txt_gp = obj$txt_gp,
    col = obj$col
  )
  obj$labels <- NULL

  lines <- prepLines(
    lines = obj$lines,
    is.summary = obj$is.summary,
    number_of_columns = attr(labels, "no_cols") + 1,
    number_of_rows = attr(labels, "no_rows"),
    col = obj$col,
    shapes_gp = obj$shapes_gp
  )


  missing_rows <- apply(obj$estimates, 2, \(row) all(is.na(row)))

  fn.ci_norm <- prFpGetConfintFnList(
    fn = obj$fn.ci_norm,
    no_rows = nrow(obj$estimates),
    no_depth = dim(obj$estimates)[3],
    missing_rows = missing_rows,
    is.summary = obj$is.summary,
    summary = FALSE
  )
  obj$fn.ci_norm <- NULL
  fn.ci_sum <- prFpGetConfintFnList(
    fn = obj$fn.ci_sum,
    no_rows = nrow(obj$estimates),
    no_depth = dim(obj$estimates)[3],
    missing_rows = missing_rows,
    is.summary = obj$is.summary,
    summary = TRUE
  )
  obj$fn.ci_sum <- NULL
  lty.ci <- prPopulateList(obj$lty.ci,
    no_rows = nrow(obj$estimates),
    no_depth = dim(obj$estimates)[3]
  )
  obj$lty.ci <- NULL

  xRange <- prFpXrange(
    upper = obj$estimates[, 3, ],
    lower = obj$estimates[, 2, ],
    clip = obj$clip,
    zero = obj$zero,
    xticks = obj$xticks,
    xlog = obj$xlog
  )

  axisList <- prFpGetGraphTicksAndClips(
    xticks = obj$xticks,
    xticks.digits = obj$xticks.digits,
    grid = obj$grid,
    xlog = obj$xlog,
    xlab = obj$xlab,
    lwd.xaxis = obj$lwd.xaxis,
    lwd.zero = obj$lwd.zero,
    txt_gp = obj$txt_gp,
    col = obj$col,
    clip = obj$clip,
    zero = obj$zero,
    x_range = xRange,
    estimates = obj$estimates,
    graph.pos = obj$graph.pos,
    graph_favors = obj$graph_favors,
    shapes_gp = obj$shapes_gp
  )

  marList <- prepGridMargins(mar = obj$mar)
  prPushMarginViewport(
    bottom = marList$bottom,
    left = marList$left,
    top = marList$top,
    right = marList$right,
    name = "forestplot_margins"
  )

  if (!all(is.na(obj$title))) {
    prGridPlotTitle(title = obj$title, gp = obj$txt_gp$title)
  }

  legend <- buildLegend(
    legend = obj$legend,
    txt_gp = obj$txt_gp,
    legend_args = obj$legend_args,
    colgap = obj$colgap,
    col = obj$col,
    shapes_gp = obj$shapes_gp,
    lineheight = obj$lineheight,
    fn.legend = obj$fn.legend
  )
  attr(legend, "cex") <- attr(labels, "cex")
  attr(legend, "no_rows") <- attr(labels, "cex")

  plot(legend, margin = TRUE)

  # Add space for the axis and the label
  axis_height <- unit(0, "npc")
  if (is.grob(axisList$axisGrob)) {
    axis_height <- axis_height + grobHeight(axisList$axisGrob)
  }

  if (is.grob(axisList$labGrob)) {
    gp_lab_cex <- prGetTextGrobCex(axisList$labGrob)

    # The lab grob y actually includes the axis (note negative)
    axis_height <- axis_height +
      unit(gp_lab_cex + .5, "line")
  }

  if (is.list(axisList$graph_favors) && identical(axisList$graph_favors$position, "outside")) {
    axis_height <- axis_height + unit(1.8, "line")
    if (isTRUE(axisList$graph_favors$arrows)) {
      axis_height <- axis_height + unit(0.9, "line")
    }
  }

  axis_layout <- grid.layout(
    nrow = 2,
    ncol = 1,
    heights = unit.c(
      unit(1, "npc") - axis_height,
      axis_height
    )
  )
  pushViewport(viewport(
    layout = axis_layout,
    name = "axis_margin"
  ))
  pushViewport(viewport(layout.pos.row = 1, layout.pos.col = 1))

  colwidths <- getColWidths(
    labels = labels,
    graphwidth = obj$graphwidth,
    colgap = obj$colgap,
    graph.pos = obj$graph.pos
  )

  # The base viewport, set the increase.line_height paremeter if it seems a little
  # crowded between the lines that might happen when having multiple comparisons
  main_grid_layout <- grid.layout(
    nrow = attr(labels, "no_rows"),
    ncol = length(colwidths),
    widths = colwidths,
    heights = getLineHeight(obj, labels = labels),
    respect = TRUE
  )

  pushViewport(viewport(
    layout = main_grid_layout,
    name = "BaseGrid"
  ))

  plotZebraStyle(obj)

  info <- prepBoxSize(
    boxsize = obj$boxsize,
    estimates = obj$estimates,
    is.summary = obj$is.summary,
    txt_gp = obj$txt_gp
  )

  plot(lines,
    colwidths = colwidths,
    graph.pos = obj$graph.pos
  )

  prFpPrintLabels(
    labels = labels,
    nc = attr(labels, "no_cols"),
    nr = attr(labels, "no_rows"),
    graph.pos = obj$graph.pos
  )


  plotGraphBox(
    boxGrob = obj$graph_box,
    estimates = obj$estimates,
    graph.pos = obj$graph.pos
  )

  plot(axisList)
  plotGraphText(obj = obj)

  plotConfidenceInterval(
    obj = obj,
    axisList = axisList,
    info = info,
    labels = labels,
    fn.ci_sum = fn.ci_sum,
    fn.ci_norm = fn.ci_norm,
    lty.ci = lty.ci
  )

  if (length(legend) > 0 &&
    is.list(obj$legend_args$pos)) {
    plot(legend, margin = FALSE, legend_args = obj$legend_args, col = obj$col, graph.pos = obj$graph.pos, shapes_gp = obj$shapes_gp, legend_colgap = obj$legend_colgap)
  }

  # Go back to the original viewport
  seekViewport("forestplot_margins")
  upViewport(2)
}

getLineHeight <- function(obj, labels) {
  no_rows <- attr(labels, "no_rows")
  if (is.unit(obj$lineheight)) {
    return(unit.c(rep(obj$lineheight, length.out = no_rows)))
  }

  if (obj$lineheight == "auto" || is.null(obj$lineheight)) {
    return(unit(rep(1 / no_rows, no_rows), "npc"))
  }

  if (obj$lineheight == "lines") {
    return(unit(rep(attr(labels, "cex") * 1.5, length.out = no_rows), "lines"))
  }

  return(unit.c(rep(obj$lineheight, length.out = no_rows)))
}