R/statquote.R

In statquotes: Quotes on Statistics, Data Visualization and Science

#' @importFrom utils data
.get.sq <- function(){
  #browser()
  .sq.env <- new.env()
  data(quotes, package = 'statquotes', envir = .sq.env)
  .sq.env$quotes
}

#' Display a randomly chosen statistical quote.
#'
#' @param ind Integer or character.
#' If 'ind' is missing, a random quote is chosen from all quotations.
#' If 'ind' is specified and is an integer, return the ind^th quote.
#' If 'ind' is specified and is character, use it as the 'pattern'.
#'
#' @param pattern Character string. Quotes are subset to to those which
#' match the pattern in the quote text.
#'
#' @param tag Character string. Quotes are subset to those matching the
#' specified tag.
#'
#' @param source Character string. Quotes are subset to those matching
#' the specified source (person).
#'
#' @param topic Deprecated. Use 'tag' instead. Only kept for backward compatibility.

#' @return
#' A character vector containing one quote.
#' It is of class \code{statquote} for which an S3 print method will be invoked, and for which
#' other methods are available.
#'
#' @export
#' @importFrom stringr str_detect
#' @seealso \code{\link{quote_tags}}, \code{\link{search_quotes}}, \code{\link{quotes}},
#' Inspired by: \code{\link[fortunes]{fortune}}
#' @examples
#' set.seed(1234)
#' statquote()
#' statquote(10)
#' statquote("boggled")
#' statquote(pattern="boggled")
#' statquote(source="Yates")
#' statquote(tag="anova")
#' print.data.frame(statquote(302)) # All information
#'
statquote <- function(ind=NULL, pattern=NULL, tag=NULL, source=NULL, topic=NULL) {

  dat <- .get.sq()

  if(!missing(topic)) {
    message("`topic` is deprecated. Please use `tag` instead of `topic`. Using your `topic` as a `tag`.")
    tag=topic
  }

  # Note: is.integer(23) is FALSE, is.integer(23L) is TRUE. Make our own fun.
  isInteger <-
    function(x) is.numeric(x) && all.equal(x, as.integer(x))

  # ind is a number
  if(!missing(ind) && isInteger(ind)) {
    if (min(ind)<1 | max(ind) > nrow(dat))
      stop("Numerical `ind` must be between 1 and ", nrow(dat))
    dat <- dat[ind,]
  }
  # ind is string, use it as 'pattern'
  if(!missing(ind) && is.character(ind)){
    OK <- which(str_detect(tolower(dat$text), tolower(ind)))
    dat <- dat[OK,]
	  }


  # Now 'ind' is missing
  if(missing(ind) && !is.null(tag)) {
    OK <- which(str_detect(tolower(dat$tags), tolower(tag)))
    dat <- dat[OK,]
	}

  if(missing(ind) && !is.null(source) ) {
    OK <- which(str_detect(tolower(dat$source), tolower(source)))
    dat <- dat[OK,]
	}

  if(missing(ind) && !is.null(pattern) ) {
    OK <- which(str_detect(tolower(dat$text), tolower(pattern)))
    dat <- dat[OK,]
  }

  if(nrow(dat)<1) stop("No matches found")

  # Finally, pick one at random
  ind <- sample(1:nrow(dat),1)

  res <- dat[ind,]
  class(res) <- c("statquote", 'data.frame')
  return(res)
}

#' @rdname statquote
#' @param x     object of class \code{'statquote'}
#' @param cite  logical; should the \code{cite} field be printed?
#' @param width Optional print width parameter
#' @param ...   Other optional arguments, unused here
#' @export
#'
print.statquote <- function(x, cite = TRUE, width = NULL, ...) {
    if (is.null(width)) width <- 0.9 * getOption("width")
    if (width < 10) stop("'width' must be greater than 10", call.=FALSE)
    x <- x[ ,c('text', 'source', 'cite')]
    if (nrow(x) > 1){
      for(i in 1L:nrow(x)){
        print(x[i,], cite=cite, width=width, ...)
      }
    } else {
      x$source <- paste("---", x$source)
      if(isTRUE(cite) && !is.na(x$cite)) {
        x$source <- paste0(x$source, ", ", x$cite)
      }
      out <- c(paste0("\n", strwrap(x$text, width)),
               paste0("\n", strwrap(x$source, width)))
      sapply(out, cat)
      cat("\n")
    }
    invisible()
}

#' @rdname statquote
#' @param row.names see \code{\link{as.data.frame}}
#' @param optional see \code{\link{as.data.frame}}
#' @seealso \code{\link{as.latex}}, \code{\link{as.markdown}}
#' @export
#'
as.data.frame.statquote <- function(x, row.names = NULL,
                                    optional = FALSE, ...) {
  class(x) <- 'data.frame'
  x
}

#' List the tags of the quotes database
#'
#' This function finds the unique tags of items in the  quotes database and returns them
#' as vector or a one-way  table giving their frequencies.
#'
#' @param table Logical. If \code{table=TRUE}, return a one-way frequency table
#' of quotes for each tag; otherwise return the sorted vector of unique tags.
#'
#' @return Returns either a vector of tags in the quotes database or a one-way
#' frequency table of the number of quotes for each tag.
#'
#' @export
#'
#' @examples
#' quote_tags()
#' quote_tags(table=TRUE)
#'
#' library(ggplot2)
#' qt <- quote_tags(table=TRUE)
#' qtdf <-as.data.frame(qt)
#' # bar plot of frequencies
#' ggplot2::ggplot(data=qtdf, aes(x=Freq, y=tags)) +
#'     geom_bar(stat = "identity")
#'
#' # Sort tags by frequency
#' qtdf |>
#'   dplyr::mutate(tags = forcats::fct_reorder(tags, Freq)) |>
#'   ggplot2::ggplot(aes(x=Freq, y=tags)) +
#'   geom_bar(stat = "identity")
#'
quote_tags <- function (table = FALSE) {
  data <- .get.sq()
  tags <- data[, "tags"]
  tags <- unlist(strsplit(tags, ","))
  tags <- trimws(tags)
  tags <- tags[!is.na(tags)]
  if (table) {
    table(tags)
  }
  else {
    tags <- unique(tags)
    sort(tags)
  }
}

#' Coerces statquote objects to strings suitable for LaTeX
#'
#' This function coerces statquote objects to strings suitable for rendering in LaTeX.
#' Quotes and (potential LaTeX) sources are placed within suitable "\code{epigraph}" output
#' format via the \code{\link{sprintf}} function.
#'
#' @param quotes an object of class \code{statquote} returned from functions such as
#'   \code{\link{search_quotes}} or \code{\link{statquote}}
#'
#' @param form structure of the LaTeX output for the text (first argument)
#'   and source (second argument) passed to \code{\link{sprintf}}
#'
#' @param cite logical; should the \code{cite} field be included in the source output?
#'
#' @return character vector of formatted LaTeX quotes
#'
#' @export
#' @author Phil Chalmers
#' @seealso \code{\link{as.data.frame.statquote}}, \code{\link{as.markdown}}
#' @examples
#'
#' ll <- search_quotes("Tukey")
#' as.latex(ll)
#'

as.latex <- function(quotes, form = "\\epigraph{%s}{%s}\n\n", cite = TRUE){

  stopifnot('statquote' %in% class(quotes))
  #replace the common csv symbols with LaTeX versions
  symbols2tex <- function(strings){
    strings <- as.character(strings)
    loc <- stringr::str_locate_all(strings, '\\*.?')
    pick <- which(sapply(loc, length) > 0)
    for(i in pick){
      index <- seq(1, nrow(loc[[i]]), by=2)
      for(j in length(index):1L)
        stringr::str_sub(strings[i], loc[[i]][index[j], 1L], loc[[i]][index[j], 1L]) <- '\\emph{'
    }
    strings <- stringr::str_replace_all(strings, '\\*', '}')
    strings <- stringr::str_replace_all(strings, ' \"', '``')
    strings
  }

  quotes$text <- symbols2tex(quotes$text)
  quotes$source <- if(cite) symbols2tex(paste0(quotes$source, ", ", quotes$cite))
    else symbols2tex(quotes$source)
  lines <- NULL
  if(is.null(quotes$TeXsource)) quotes$TeXsource <- ""
  for(i in 1:nrow(quotes)){
    lines <- c(lines, sprintf(form, quotes$text[i],
                              if(quotes$TeXsource[i] != "") quotes$TeXsource[i] else quotes$source[i]))
  }
  lines
}