R/LDA_plots.R

Defines functions plot.LDA_set plot.LDA_VEM LDA_plot_top_panel LDA_plot_bottom_panel set_LDA_plot_colors

Documented in LDA_plot_bottom_panel LDA_plot_top_panel plot.LDA_set plot.LDA_VEM set_LDA_plot_colors

#' @title Plot a set of LDATS LDA models
#'
#' @description Generalization of the \code{\link[graphics]{plot}} function to 
#'   work on a list of LDA topic models (class \code{LDA_set}). 
#' 
#' @param x An \code{LDA_set} object of LDA topic models.
#' 
#' @param ... Additional arguments to be passed to subfunctions.
#' 
#' @return \code{NULL}.
#'
#' @examples 
#' \donttest{
#'   data(rodents)
#'   lda_data <- rodents$document_term_table
#'   r_LDA <- LDA_set(lda_data, topics = 2, nseeds = 2) 
#'   plot(r_LDA)
#' }
#'
#' @export 
#'
plot.LDA_set <- function(x, ...){
  on.exit(devAskNewPage(FALSE))
  if (length(x) > 1){
    devAskNewPage(TRUE)
  }
  y <- lapply(x, plot, ...)
  y <- NULL
}

#' @title Plot the results of an LDATS LDA model
#'
#' @description Create an LDATS LDA summary plot, with a top panel showing
#'   the topic proportions for each word and a bottom panel showing the topic
#'   proportions of each document/over time. The plot function is defined for
#'   class \code{LDA_VEM} specifically (see \code{\link[topicmodels]{LDA}}).
#'   \cr \cr
#'   \code{LDA_plot_top_panel} creates an LDATS LDA summary plot 
#'   top panel showing the topic proportions word-by-word. \cr \cr
#'   \code{LDA_plot_bottom_panel} creates an LDATS LDA summary plot
#'   bottom panel showing the topic proportions over time/documents. 
#' 
#' @param x Object of class \code{LDA_VEM}.
#'
#' @param xtime Optional x values used to plot the topic proportions according
#'   to a specific time value (rather than simply the order of observations).
#'
#' @param xname Optional name for the x values used in plotting the topic
#'   proportions (otherwise defaults to "Document"). 
#'
#' @param cols Colors to be used to plot the topics.
#'   Any valid color values (\emph{e.g.}, see \code{\link[grDevices]{colors}},
#'   \code{\link[grDevices]{rgb}}) can be input as with a standard plot. 
#'   The default (\code{cols = NULL}) triggers use of 
#'   \code{\link[viridis]{viridis}} color options (see \code{option}).
#'
#' @param option A \code{character} string indicating the color option
#'   from \code{\link[viridis]{viridis}} to use if `cols == NULL`. Four 
#'   options are available: "magma" (or "A"), "inferno" (or "B"), "plasma" 
#'   (or "C", the default option), "viridis" (or "D") and "cividis" (or "E").
#'
#' @param alpha Numeric value [0,1] that indicates the transparency of the 
#'   colors used. Supported only on some devices, see 
#'   \code{\link[grDevices]{rgb}}.
#'
#' @param together \code{logical} indicating if the subplots are part of a 
#'   larger LDA plot output. 
#'
#' @param LDATS \code{logical} indicating if the LDA plot is part of a larger 
#'   LDATS plot output. 
#'
#' @param ... Not used, retained for alignment with base function.
#' 
#' @return \code{NULL}.
#' 
#' @examples 
#' \donttest{
#'   data(rodents)
#'   lda_data <- rodents$document_term_table
#'   r_LDA <- LDA_set(lda_data, topics = 4, nseeds = 10) 
#'   best_lda <- select_LDA(r_LDA)[[1]]
#'   plot(best_lda, option = "cividis")
#'   LDA_plot_top_panel(best_lda, option = "cividis")
#'   LDA_plot_bottom_panel(best_lda, option = "cividis")
#' }
#'
#' @export 
#'
plot.LDA_VEM <- function(x, ..., xtime = NULL, xname = NULL, cols = NULL, 
                     option = "C", alpha = 0.8, LDATS = FALSE){
  LDA_plot_top_panel(x, cols, option, alpha, TRUE, LDATS)
  LDA_plot_bottom_panel(x, xtime, xname, cols, option, alpha, TRUE, LDATS)
}

#' @rdname plot.LDA_VEM 
#' 
#' @export 
#'
LDA_plot_top_panel <- function(x, cols = NULL, option = "C", alpha = 0.8, 
                               together = FALSE, LDATS = FALSE){
  oldpar <- par(no.readonly = TRUE)
  on.exit(par(oldpar))
  cols <- set_LDA_plot_colors(x, cols, option, alpha)
  gamma <- x@gamma
  beta <- exp(x@beta)
  nobs <- nrow(gamma)
  ntopics <- ncol(gamma)
  nwords <- ncol(beta)
  beta_order <- apply(beta, 2, order)
  beta_sorted <- apply(beta, 2, sort)

  counter <- 1
  rect_mat <- matrix(NA, nrow = nwords * ntopics, ncol = 4)
  rect_col <- rep(NA, length = nwords * ntopics)
  for (i in 1:nwords){
    x1 <- i - 0.4
    x2 <- i + 0.4
    y1 <- 0
    y2 <- 0
    for (j in 1:ntopics){
      y1 <- y2
      y2 <- y1 + beta_sorted[j, i]
      rect_mat[counter, ] <- c(x1, y1, x2, y2)      
      rect_col[counter] <- cols[beta_order[j, i]]
      counter <- counter + 1
    }
  }

  if (LDATS){
    par(fig = c(0, 0.9, 0.85, 1))
  } else if(together){
    par(fig = c(0, 0.9, 0.7, 1))
  } else{
    par(fig = c(0, 0.9, 0, 1))
  }
  par(mar = c(1, 3.5, 1, 0))
  max_y <- max(rect_mat[,4]) * 1.05
  plot(1, 1, type = "n", bty = "L", xlab = "", ylab = "", las = 1,
       ylim = c(0, max_y), xlim = c(1, nwords), xaxt = "n", cex.axis = 0.75)  
  mtext(side = 2, "Total Proportion", line = 2.5, cex = 0.75)
  for (i in 1:(nwords * ntopics)){
    rect(rect_mat[i, 1], rect_mat[i, 2], rect_mat[i, 3], rect_mat[i, 4],
         col = rect_col[i])
  }
  axis(2, at = seq(0, max_y, 0.1), labels = FALSE, tck = -0.02)
  mtext(side = 1, at = seq(1, nwords, 1), text = x@terms, tck = 0, 
       cex = 0.5, line = 0)

  if (LDATS){
    par(fig = c(0.9, 1, 0.85, 1)) 
  } else if (together){ 
    par(fig = c(0.9, 1, 0.7, 1)) 
  } else{
    par(fig = c(0.9, 1, 0, 1))
  }
  par(mar = c(0, 0, 0, 0), new = TRUE)
  plot(1, 1, type = "n", bty = "n", xlab = "", ylab = "", 
       xaxt = "n", yaxt = "n", ylim = c(0, 1), xlim = c(0,1))

  ypos <- (0.9 / ntopics) * (ntopics:1)
  ttext <- paste("Topic ", 1:ntopics, sep = "")
  for (i in 1:ntopics){
    text(ttext[i], x = 0.25, y = ypos[i], adj = 0, cex = 0.75)
    rect(0.0, ypos[i] - 0.05, 0.15, ypos[i] + 0.05, col = cols[i])
  }
}

#' @rdname plot.LDA_VEM
#' 
#' @export 
#'
LDA_plot_bottom_panel <- function(x, xtime = NULL, xname = NULL, cols = NULL,
                                  option = "C", alpha = 0.8, 
                                  together = FALSE, LDATS = FALSE){
  oldpar <- par(no.readonly = TRUE)
  on.exit(par(oldpar))
  cols <- set_LDA_plot_colors(x, cols, option, alpha)
  gamma <- x@gamma
  ntopics <- ncol(gamma)

  if (is.null(xtime)){
    xtime <- seq(1, nrow(gamma), 1)
  }
  if (is.null(xname) & !LDATS){
    xname <- "Document"
  }

  if (LDATS){
    par(fig = c(0, 1, 0.53, 0.85), new = TRUE)
  } else if (together){
    par(fig = c(0, 1, 0, 0.7), new = TRUE)
  } else{
    par(fig = c(0, 1, 0, 1))
  }
  par(mar = c(3.25, 5, 1, 1))
  plot(xtime, gamma[ , 1], type = "n", bty = "L", xlab = "", ylab = "", 
       las = 1, ylim = c(0, 1))
  mtext(side = 1, xname, line = 2.2, cex = 1.25)
  mtext(side = 2, "Proportion", line = 3.5, cex = 1.25)
  for (i in 1:ntopics){
    points(xtime, gamma[ , i], col = cols[i], type = "l", lwd = 2)
  }
}

#' @title Prepare the colors to be used in the LDA plots
#'
#' @description Based on the inputs, create the set of colors to be used in
#'   the LDA plots made by \code{\link{plot.LDA_TS}}.
#' 
#' @param x Object of class \code{LDA}.
#'
#' @param cols Colors to be used to plot the topics.
#'   Any valid color values (\emph{e.g.}, see \code{\link[grDevices]{colors}},
#'   \code{\link[grDevices]{rgb}}) can be input as with a standard plot. 
#'   The default (\code{cols = NULL}) triggers use of 
#'   \code{\link[viridis]{viridis}} color options (see \code{option}).
#'
#' @param option A \code{character} string indicating the color option
#'   from \code{\link[viridis]{viridis}} to use if `cols == NULL`. Four 
#'   options are available: "magma" (or "A"), "inferno" (or "B"), "plasma" 
#'   (or "C", the default option), "viridis" (or "D") and "cividis" (or "E").
#'
#' @param alpha Numeric value [0,1] that indicates the transparency of the 
#'   colors used. Supported only on some devices, see 
#'   \code{\link[grDevices]{rgb}}.
#'
#' @return \code{vector} of \code{character} hex codes indicating colors to 
#'   use.
#'
#' @examples
#' \donttest{
#'   data(rodents)
#'   lda_data <- rodents$document_term_table
#'   r_LDA <- LDA_set(lda_data, topics = 4, nseeds = 10) 
#'   set_LDA_plot_colors(r_LDA[[1]])
#' }
#'
#' @export 
#'
set_LDA_plot_colors <- function(x, cols = NULL, option = "C", alpha = 0.8){

  gamma <- x@gamma
  ntopics <- ncol(gamma)
  if (length(cols) == 0){
    cols <- viridis(ntopics, option = option, alpha = alpha, end = 0.9)
  }
  if (length(cols) == 1){
    if (cols == "greys" | cols == "grey" | cols == "grays" | cols == "gray"){
      ggg <- seq(0, 0.8, length.out = ntopics)
      cols <- rep(NA, ntopics)
      for (i in 1:ntopics){
       cols[i] <- rgb(ggg[i], ggg[i], ggg[i])
      }
    }
  }
  if (length(cols) > ntopics){
    cols <- cols[1:ntopics]
  }
  if (length(cols) < ntopics){
    nc <- length(cols)
    nt <- ntopics
    msg <- paste0("Fewer colors (", nc, ") provided than topics (", nt, ")")
    stop(msg)
  }
  cols
}

Try the LDATS package in your browser

Any scripts or data that you put into this service are public.

LDATS documentation built on March 20, 2020, 1:09 a.m.