R/makeci.R

In forestploter: Create a Flexible Forest Plot

#' Create confidence interval grob
#'
#' @inheritParams forest
#' @inheritParams set_xaxis
#' @param pch Numeric or character vector indicating what sort of plotting
#' symbol to use. See \code{\link[grid]{pointsGrob}}.
#' @param gp Graphical parameters of \code{\link[grid]{gpar}}. Please refer
#'  to \code{\link{forest_theme}} for more details.
#' @param t_height The height of the confidence interval line end vertices.
#' If the value is `NULL` (default), no vertices will be drawn.
#' @param name Name of the grob.
#' 
#' @return A gTree object
#'
#' @export
makeci <- function(est, lower, upper, pch, sizes = 1, gp = gpar(),
                   t_height = NULL, xlim = c(0, 1), nudge_y = 0,
                   name = NULL){

  gTree(
    est = est, lower = lower, upper = upper, pch = pch,
    size = sizes, gp = gp, t_height = t_height,
    xlim = xlim, nudge_y = nudge_y, name = name,
    # vp = viewport(xscale = xlim),
    cl = "makeci"
  )

}

#' @export
makeContext.makeci <- function(x) {
  tbvp <- viewport(xscale = x$xlim)
  if (is.null(x$vp))
    x$vp <- tbvp
  else
    x$vp <- vpStack(x$vp, tbvp)
  x
}

#' @export
makeContent.makeci <- function(x) {

  kids <- makeci_static(est = x$est, lower = x$lower, upper = x$upper,
                        pch = x$pch, size = x$size, gp =  x$gp,
                        t_height = x$t_height, xlim = x$xlim,
                        nudge_y = x$nudge_y)

  setChildren(x, kids)
}

# Main function for confidence intervals
#' @keywords internal
makeci_static <- function(est, lower, upper, pch, size = 1, gp = gpar(),
                          t_height = NULL, xlim = c(0, 1), nudge_y = 0){

  # Return NULL if the CI is outside
  if(upper < min(xlim) || lower > max(xlim))
    return(gList(nullGrob()))

  # Point estimation
  rec_gp <- gp
  rec_gp$col <- gp$fill
  rec <- pointsGrob(x = unit(est, "native"),
                    y = 0.5 + nudge_y,
                    pch = pch,
                    size = size_bigpts(size, gp),
                    gp = rec_gp,
                    name = "point")

  # Center indication if alpha is not 1
  if(!is.null(gp$alpha) && gp$alpha != 1){
    gp$alpha <- NULL
    cent_gp <- segmentsGrob(x0 = unit(est, "native"), x1 = unit(est, "native"),
                            y0 = unit(0.5 + nudge_y, "npc") - size_bigpts(size*.2, gp),
                            y1 = unit(0.5 + nudge_y, "npc") + size_bigpts(size*.2, gp),
                            gp = gp, name = "center")

  }else {
    cent_gp <- nullGrob()
  }

  if(upper > max(xlim) || lower < min(xlim)){
    # Both sides arrow
    if(upper > max(xlim) && lower < min(xlim)){
      x_pos <- unit(c(0, 1), c("npc", "npc"))
      arrow_side <- "both"
      x_vert <- NULL
    }

    # Left side arrow
    else if(lower < min(xlim) && upper < max(xlim)){
      x_pos <- unit(c(0, upper), c("npc", "native"))
      arrow_side <- "first"
      x_vert <- unit(upper, "native")
    }

    # Right side arrow
    else{
      x_pos <- unit(c(lower, 1), c("native", "npc"))
      arrow_side <- "last"
      x_vert <- unit(lower, "native")
    }

    lng <- linesGrob(x=x_pos, y = 0.5 + nudge_y,
                     arrow=arrow(length=unit(0.05, "inches"),
                                 ends = arrow_side),
                     gp=gp)
  } else {
    lng <- linesGrob(x=unit(c(lower, upper), "native"), y=0.5 + nudge_y,
                     gp=gp)

    x_vert <- unit(c(lower, upper),  "native")
  }

  # Draw T end to the CI
  if(!is.null(t_height) && !is.null(x_vert)){
    if(!is.unit(t_height))
      t_height <- unit(t_height, "npc")

    vert <- segmentsGrob(x0 = x_vert, y0 = unit(0.5 + nudge_y, "npc") - t_height/2,
                         x1 = x_vert, y1 = unit(0.5 + nudge_y, "npc") + t_height/2,
                         gp = gp,
                         name = "T.end")
  }else {
    vert <- nullGrob()
  }

  # No dots if outside
  if(est > max(xlim) || est < min(xlim))
    rec <- nullGrob()

  gList(cent_gp, lng, vert, rec)

}


#' Create pooled summary diamond shape
#'
#' @inheritParams forest
#' @inheritParams set_xaxis
#' @param gp Graphical parameters of \code{\link[grid]{gpar}}.
#'  Please refer to \code{\link{forest_theme}} for more details.
#' 
#' @return A gTree object
#'
#' @export
make_summary <- function(est, lower, upper, sizes = 1, gp, xlim, nudge_y = 0){

  # Return NULL if the CI is outside
  if(upper < min(xlim) || lower > max(xlim))
    return(NULL)

  # `sizes` is the full height of the diamond, in the same unit as the point
  # estimation of a non-summary row: a multiple of one line of text.
  mid <- unit(0.5 + nudge_y, "npc")
  half <- size_bigpts(0.5 * sizes, gp)

  polygonGrob(x = unit(c(lower, est, upper, est), "native"),
              y = unit.c(mid, mid + half, mid, mid - half),
              gp = gp,
              vp = viewport(xscale = xlim),
              name = "pooled.diamond")
}