inst/extR/ggplot_fmx.R

In fmx: Finite Mixture Parametrization

# source('./inst/extR/ggplot_fmx.R')
library(ggplot2)
library(latex2exp)

#' @title Show \linkS4class{fmx} Object
#' 
#' @description
#' Print the parameters of an \linkS4class{fmx} object and plot its density curves.
#' 
#' @param object an \linkS4class{fmx} object
#' 
#' @returns 
#' The \link[methods]{show} method for \linkS4class{fmx} object 
#' does not have a returned value.
#' 
#' @keywords internal
#' @importFrom ggplot2 xlim
#' @export
setMethod(f = show, signature = signature(object = 'fmx'), definition = function(object) {
  print.fmx(object)
  if (length(test_table <- attr(object, which = 'steps', exact = TRUE))) {
    direction <- attr(object, which = 'direction', exact = TRUE)
    cat('Stepwise Parameter', switch(direction, drop1 = 'Elimination', add1 = 'Growth'), '(Fixed # of Components)\n')
    print.data.frame(test_table)
    cat('\n')
  }
  
  p <- if (length(object@data)) {
    autoplot.fmx(object)
  } else {
    xlim_ <- qfmx(p = c(.01, .99), dist = object)
    autoplot.fmx(object) + xlim(xlim_[1L], xlim_[2L])
  }
  print(p)
  return(invisible())
})










#' @title Create \link[ggplot2]{layer} for Continuous \linkS4class{fmx} Objects
#' 
#' @description ..
#' 
#' @param object \linkS4class{fmx} object
#' 
#' @param type \link[base]{character} scalar.  
#' Option `'density'` (default) plots the probability density for \linkS4class{fmx} input
#' (and the histogram if argument `data` is available).
#' Option `'distribution'` plots the cumulative probability distribution for \linkS4class{fmx} input 
#' (and the empirical cumulative distribution if argument `data` is available).
#' 
#' @param data (optional) \link[base]{numeric} \link[base]{vector} of the observations.
#' Default is the slot `object@@data`.
#' 
#' @param hist.fill color of the body of histogram, default `'grey95'`
#' 
#' @param n \link[base]{integer}, see \link[ggplot2]{stat_function}
#' 
#' @param curve.col color of the density curve of the fitted finite mixture distribution.
#' Default `'black'`
#' 
#' @param probs \link[base]{numeric} \link[base]{vector}, 
#' where the corresponding quantiles are plotted as vertical lines.
#' Default `probs = numeric()` to suppress the printing of these lines.
#' 
#' @param ... potential parameters of \link[ggplot2]{stat_function}
#' 
#' @returns 
#' 
#' Function [autolayer_fmx_continuous()] returns a \link[base]{list} of \link[ggplot2]{layer}s.
#' 
#' @seealso 
#' \link[ggplot2]{autolayer} 
#' 
#' @keywords internal
#' @importFrom ggplot2 geom_histogram stat_function stat_ecdf geom_vline geom_text
#' @export
autolayer_fmx_continuous <- function(
    object, 
    type = c('density', 'distribution'), 
    data = object@data,
    probs = numeric(),
    # init = attr(object, which = 'init', exact = TRUE), 
    hist.fill = 'grey95', 
    curve.col = 1, # black curve, default
    n = 1001L,
    ...
) {
  
  type <- match.arg(type)
  fun <- switch(type, density = dfmx, distribution = pfmx)
  
  data_lyr <- if (length(data)) {
    switch(type, density = list(
      geom_histogram(mapping = aes(x = data, y = after_stat(density)), colour = 'white', fill = hist.fill, bins = 30L),
      stat_function(fun = approxdens(data), n = n, colour = 'grey70', linetype = 2L, ...)
    ), distribution = list(
      stat_ecdf(mapping = aes(x = data), geom = 'step', pad = FALSE, colour = 'grey70', linetype = 2L)
    ))
  } # else NULL
  
  prob_lyr <- if (length(probs)) {
    v <- if (length(data)) quantile(x = data, probs = probs) else qfmx(p = probs, dist = object)
    vnm <- sprintf('%.1f%%', 1e2*probs)
    list(
      geom_vline(mapping = aes(xintercept = v, colour = vnm), linewidth = .2, show.legend = FALSE),
      geom_text(mapping = aes(x = v, y = 0, colour = vnm, label = vnm, hjust = -.5), size = 3, angle = 90, show.legend = FALSE)
    )
  } # else NULL
  
  ret <- list(
    data_lyr, prob_lyr,
    stat_function(fun = fun, args = list(dist = object), n = n, colour = curve.col, ...)#,
    #switch(type, distribution = scale_y_continuous(labels = percent))
  )
  return(ret[lengths(ret) > 0L])
  
}





#' @title Create \link[ggplot2]{layer} for Discrete \linkS4class{fmx} Objects
#' 
#' @description ..
#' 
#' @param object \linkS4class{fmx} object
#' 
#' @param type \link[base]{character} scalar.  
#' Option `'density'` (default) plots the probability density for \linkS4class{fmx} input
#' (and the histogram if argument `data` is available).
#' Option `'distribution'` plots the cumulative probability distribution for \linkS4class{fmx} input 
#' (and the cumulative histogram if argument `data` is available).
#' 
#' @param data (optional) \link[base]{numeric} (actually \link[base]{integer}) \link[base]{vector} of the observations.
#' Default is the slot `object@@data`.
#' 
#' @param bins \link[base]{integer} scalar
#' 
#' @param xlim \link[base]{numeric} length-two \link[base]{vector}, horizontal range
#' 
#' @param ... additional parameters, currently not in use
#' 
#' @returns 
#' 
#' Function [autolayer_fmx_discrete()] returns a \link[base]{list} of \link[ggplot2]{layer}s.
#' 
#' @seealso 
#' \link[ggplot2]{autolayer}
#' 
#' @importFrom ggplot2 geom_histogram stat_ecdf
#' @export
autolayer_fmx_discrete <- function(
    object, 
    type = c('density', 'distribution'), 
    data = object@data,
    xlim = if (length(data)) data else qfmx(p = c(.01, .99), dist = object),
    bins = 60L,
    ...
) {
  
  type <- match.arg(type)
  fun <- switch(type, density = dfmx, distribution = pfmx)
  
  if (anyNA(xlim) || !(nL <- length(xlim))) stop('`xlim` must be integer')
  x0 <- if (nL == 1L) {
    if (xlim <= 0) stop('right end of `xlim` must be positive')
    0L:ceiling(xlim)
  } else {
    if (any(xlim < 0L)) stop('`xlim` must be non-negative')
    floor(min(xlim)):ceiling(max(xlim))
  } 
  
  y <- fun(x0, dist = object)
  
  return(list(
    if (length(data)) {
      switch(type, density = {
        geom_histogram(mapping = aes(x = data, y = after_stat(density)), bins = bins, colour = 'white', alpha = .1, show.legend = FALSE)
      }, distribution = {
        stat_ecdf(mapping = aes(x = data), geom = 'step', pad = FALSE, colour = 'grey70', linetype = 2L, show.legend = FALSE)
      })
    },
    geom_step(mapping = aes(x = x0, y = y), stat = 'identity')
  ))
  
}










#' @title Plot \linkS4class{fmx} Objects using \CRANpkg{ggplot2}
#' 
#' @description 
#' 
#' Plot \linkS4class{fmx} objects using \CRANpkg{ggplot2}.
#' 
#' @param object \linkS4class{fmx} object
#' 
#' @param ... potential parameters of [autolayer_fmx_continuous] and [autolayer_fmx_discrete]
#' 
#' @returns 
#' 
#' Function [autoplot.fmx()] returns a \link[ggplot2]{ggplot} object.
#' 
#' @seealso [autolayer_fmx_continuous()] [autolayer_fmx_discrete()]
#' 
#' @examples 
#' (d2 = fmx('GH', A = c(1,6), B = 2, g = c(0,.3), h = c(.2,0), w = c(1,2)))
#' curve(dfmx(x, dist = d2), xlim = c(-3, 11))
#' curve(pfmx(x, dist = d2), xlim = c(-3, 11))
#' autoplot.fmx(d2) + xlim(-3, 11)
#' autoplot.fmx(d2, xlim = c(-3, 11)) # equivalent
#' autoplot.fmx(d2, type = 'distribution') + xlim(-3, 11)
#' 
#' # not using function [autoplot.fmx()]
#' library(ggplot2)
#' library(latex2exp)
#' ggplot() + geom_function(fun = dfmx, args = list(dist = d2)) + 
#'   labs(title = TeX(getTeX(d2)), y = NULL) +
#'   xlim(-3, 11)
#' 
#' @importFrom ggplot2 autoplot ggplot labs
#' @importFrom latex2exp TeX
#' @export autoplot.fmx
#' @export
autoplot.fmx <- function(object, ...) {
  ggplot() + 
    (if (object@distname %in% c(distType('continuous'), distType('nonNegContinuous'))) autolayer_fmx_continuous else autolayer_fmx_discrete)(object, ...) +
    labs(
      x = object@data.name, 
      y = NULL, # paste(object@distname, 'mixture'), 
      title = TeX(getTeX(object)), 
      caption = NULL #if (nv <- length(v)) paste(nv, 'percentiles to match')
    )
}