R/plot.fdt_cat.default.R

In fdth: Frequency Distribution Tables, Histograms and Polygons

plot.fdt_cat.default <- function (x,
                                  type = c('fb', 'fp', 'fd',
                                           'rfb', 'rfp', 'rfd',
                                           'rfpb', 'rfpp', 'rfpd',
                                           'cfb', 'cfp', 'cfd',
                                           'cfpb', 'cfpp', 'cfpd',
                                           'pa'),
                                  v = FALSE,
                                  v.round = 2,
                                  v.pos = 3,
                                  xlab = NULL,
                                  xlas = 0,
                                  ylab = NULL,
                                  y2lab = NULL,
                                  y2cfp = seq(0,
                                              100,
                                              25),
                                  col = gray(.4),
                                  xlim = NULL,
                                  ylim = NULL,
                                  main = NULL,
                                  box = FALSE, ...)
{
  # barplot
  plot_b <- function(...)
  {
    cw <- max(sapply(names(y),
                     nchar))

    if (xlas == 1) 
      mar <- c(1, 
               1, 
               0, 
               2)
    else 
      mar <- c(log(max(cw), 2),
               0,
               0,
               2)

    oldpar <- par(mar = pmax(par('mar') + mar,
                             c(4.1,
                               4.1,
                               3.1,
                               4.1)),
                  las = xlas,
                  no.readonly = TRUE)

    on.exit(par(oldpar))

    mp <-  barplot(y,
                   xlab = xlab,
                   col = col,
                   xlim = xlim,
                   ylim = ylim,   
                   main = main, 
                   yaxt = 'n', ...)

    rect(mp - 0.5,
         rep(0, length(y)),
         mp + 0.5,
         y, 
         col = col)

    if (box)
      box()

    axis(2, 
         las = 3)

    mtext(ylab, 
          2, 
          line = 2.5, 
          las = 3)

    if (v) {
      text(mp,
           y,
           labels = format(round(y, v.round), nsmall = v.round),
           pos = v.pos,
           xpd = TRUE, 
           col = col, ...)
    }
  }

  # polygon
  plot_p <- function(...)
  {
    plot(1:dim(x)[1],
         y,
         type = 'b',
         xaxt = 'n',
         bty = 'n',
         xlim = xlim,
         ylim = ylim,
         xlab = xlab,
         ylab = ylab,
         col = col,
         main = main, ...)

    axis(side = 1,
         at = 1:dim(x)[1],
         labels = x$Category,
         las = xlas, ...)

    if (v) {
      text(1:dim(x)[1],  
           y,
           labels = format(round(y, v.round), nsmall = v.round),
           pos = v.pos,
           xpd = TRUE, 
           col = col, ...)
    }
  }

  # dotchart
  plot_d <- function(...)
  {
    if (is.null(xlim)) {
      ix <- min(y) * .1
      xmin <- min(y) - ix
      xmax <- max(y) + ix
      xlim <- c(xmin, xmax)
    }

    dotchart(y, 
             xlab = xlab,
             ylab = ylab,
             color = col,
             xlim = xlim,
             main = main, ...)

    if (v) {
      text(y,
           1:dim(x)[1],  
           labels = format(round(y, v.round), nsmall = v.round),
           pos = v.pos,
           xpd = TRUE, 
           col = col, ...)
    }
  }

  # pareto
  plot_pa <- function(...)
  {
    cw <- max(sapply(names(y),
                     nchar))

    if (xlas == 1) 
      mar <- c(1, 
               1, 
               0, 
               2)
    else 
      mar <- c(log(max(cw), 2),
               0,
               0,
               2)

    oldpar <- par(mar = pmax(par('mar') + mar, 
                             c(4.1, 
                               4.1, 
                               3.1, 
                               4.1)), 
                  las = xlas, 
                  no.readonly = TRUE)

    on.exit(par(oldpar))

    mp <-  barplot(y,
                   xlab = xlab,
                   col = col,
                   xlim = xlim,
                   ylim = ylim,   
                   main = main, 
                   yaxt = 'n', ...)

    if (v) {
      # f
      vf <- c(paste(y[1], 
                    round(cfp[1], 1),
                    sep = '-'),
              y[2:length(y)])

      text(mp,
           y,
           vf,
           pos = v.pos,
           xpd = TRUE, 
           col = col, ...)

      # cf-cfp
      vcfp <- c(paste(round(cf[-1], 1),
                      round(cfp[-1], 1),
                      sep = '-'))

      ifelse(length(col) > 1,
             col.tmp <- col[-1],
             col.tmp <- col)

      text(mp[-1],
           cf[-1],
           vcfp,
           pos = v.pos,
           xpd = TRUE, 
           col = col.tmp, ...)
    }

    q <- quantile(seq(0, 
                      max(cf),
                      by = max(cf) / 100),
                  y2cfp / 100)

    abline(h = q, 
           col = gray(.8), 
           lty = 3, ...)

    # clear lines over bars
    rect(mp - 0.5,
         rep(0, length(y)),
         mp + 0.5,
         y, 
         col = col, ...)

    lines(mp,
          cf, 
          type = 'b', 
          cex = 0.7, 
          pch = 19,
          col = col, ...)

    if (box)
      box()

    axis(2, 
         las = 3, ...)

    mtext(ylab, 
          2, 
          line = 2.5, 
          las = 3, ...)

    axis(4, 
         at = q, 
         las = 3, 
         labels = round(y2cfp, 2), ...)

    mtext(y2lab,
          4, 
          line = 2.5, 
          las = 3, ...)
  }

  switch(match.arg(type),
         # fb (frequency) - bar
         fb = {
           if(is.null(xlab))
             xlab <- 'Category'
           if(is.null(ylab))
             ylab <- 'Frequency'

           y <- x[, 2]
           names(y) <- x$Category

           if (is.null(ylim))
             ylim = c(0, 
                    max(y) * 1.3)

           plot_b(...)
         },

         # fp (frequency) - polygon
         fp = {
           if (is.null(ylim))
             ylim <- with(x,
                          c(0, 
                            1.2 * max(x[, 2])))

           if(is.null(xlab))
             xlab <- 'Category'
           if(is.null(ylab))
             ylab <- 'Frequency'

           y <- x[, 2]

           plot_p(...)
         },

         # fd (frequency) - dotchart
         fd = {
           y <- x[, 2]
           names(y) <- x$Category

           if(is.null(xlab))
             xlab <- 'Frequency'

           plot_d(...)
         },

         # pa (frequency) - pareto
         pa = {
           y <- x[, 2]
           names(y) <- x$Category

           cf <- x[, 5]
           cfp <- x[, 6]

           if (is.null(xlab))
             xlab <- 'Category'
           if (is.null(ylab))
             ylab <- 'Frequency'
           if (is.null(y2lab))
             y2lab <- 'Cumulative frequency, (%)'

           if (is.null(ylim))
             ylim = c(0, 
                    sum(y) * 1.1)

           plot_pa(...)
         },

         # rfb (relative frequency) - bar
         rfb = {
           if(is.null(xlab))
             xlab <- 'Category'
           if(is.null(ylab))
             ylab <- 'Relative frequency'

           y <- x[, 3]
           names(y) <- x$Category

           plot_b(...)
         },  

         # rfp (relative frequency) - polygon
         rfp = {
           if (is.null(ylim))
             ylim <- with(x,
                          c(0, 
                            1.2 * max(x[, 3])))

           if(is.null(xlab))
             xlab <- 'Category'
           if(is.null(ylab))
             ylab <- 'Relative frequency'

           y <- x[, 3]

           plot_p(...)
         },

         # rfd (relative frequency) - dotchart
         rfd = {
           y <- x[, 3]
           names(y) <- x$Category

           if(is.null(xlab))
             xlab <- 'Relative frequency'

           plot_d(...)
         },

         # rfpb (relative frequency %) - bar
         rfpb = {
           if(is.null(xlab))
             xlab <- 'Category'
           if(is.null(ylab))
             ylab <- 'Relative frequency (%)'

           y <- x[, 4]
           names(y) <- x$Category

           plot_b(...)
         },  

         # rfpp (relative frequency %) - polygon
         rfpp = {
           if (is.null(ylim))
             ylim <- with(x,
                          c(0, 
                            1.2 * max(x[, 4])))

           if(is.null(xlab))
             xlab <- 'Category'
           if(is.null(ylab))
             ylab <- 'Relative frequency (%)'

           y <- x[, 4]

           plot_p(...)
         },

         # rfpd (relative frequency %) - dotchart
         rfpd = {
           y <- x[, 4]
           names(y) <- x$Category

           if(is.null(xlab))
             xlab <- 'Relative frequency (%)'

           plot_d(...)
         },

         # cfb (cumulative frequency) - bar
         cfb = {
           if(is.null(xlab))
             xlab <- 'Category'
           if(is.null(ylab))
             ylab <- 'Cumulative frequency'

           y <- x[, 5]
           names(y) <- x$Category

           plot_b(...)
         },  

         # cfp (cumulative frequency) - polygon
         cfp = {
           if (is.null(ylim))
             ylim <- with(x,
                          c(0, 
                            1.2 * max(x[, 5])))

           if(is.null(xlab))
             xlab <- 'Category'
           if(is.null(ylab))
             ylab <- 'Cumulative frequency'

           y <- x[, 5]

           plot_p(...)
         },

         # cfd (cumulative frequency) - dotchart
         cfd = {
           y <- x[, 5]
           names(y) <- x$Category

           if(is.null(xlab))
             xlab <- 'Cumulative frequency'

           plot_d(...)
         },

         # cfpb (cumulative frequency %) - bar
         cfpb = {
           if(is.null(xlab))
             xlab <- 'Category'
           if(is.null(ylab))
             ylab <- 'Cumulative frequency (%)'

           y <- x[, 6]
           names(y) <- x$Category

           plot_b(...)
         },  

         # cfpp (cumulative frequency %) - polygon
         cfpp = {
           if (is.null(ylim))
             ylim <- with(x,
                          c(0, 
                            1.2 * max(x[, 6])))

           if(is.null(xlab))
             xlab <- 'Category'
           if(is.null(ylab))
             ylab <- 'Cumulative frequency (%)'

           y <- x[, 6]

           plot_p(...)
         },

         # cfpd (cumulative frequency %) - dotchart
         cfpd = {
           y <- x[, 6]
           names(y) <- x$Category

           if(is.null(xlab))
             xlab <- 'Cumulative frequency (%)'

           plot_d(...)
         })
}