R/inspect.R

In arules: Mining Association Rules and Frequent Itemsets

#######################################################################
# arules - Mining Association Rules and Frequent Itemsets
# Copyright (C) 2011-2015 Michael Hahsler, Christian Buchta,
#			Bettina Gruen and Kurt Hornik
#
# This program is free software; you can redistribute it and/or modify
# it under the terms of the GNU General Public License as published by
# the Free Software Foundation; either version 2 of the License, or
# any later version.
#
# This program is distributed in the hope that it will be useful,
# but WITHOUT ANY WARRANTY; without even the implied warranty of
# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
# GNU General Public License for more details.
#
# You should have received a copy of the GNU General Public License along
# with this program; if not, write to the Free Software Foundation, Inc.,
# 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA.

#' Display Associations and Transactions in Readable Form
#'
#' Provides the generic function `inspect()` and methods to display
#' [associations] and [transactions] plus additional information formatted for
#' online inspection.
#'
#' `inspect()` prints the results directly. If you need to create a data.frame
#' with a human readable version, then you can use [DATAFRAME()].
#' 
#' @aliases inspect
#' @family associations functions
#' @family itemMatrix and transactions functions
#' 
#' @param x a set of [associations] or [transactions] or an [itemMatrix].
#' @param ... additional arguments.
#'  can be used to customize the output:
#' @param setStart set start symbol
#' @param setEnd set end symbol 
#' @param itemSep item separator
#' @param ruleSep rule separator
#' @param linebreak print only one element per line in case the output lines get very long? 
#'
#' @return Nothing is returned (see the Details Section).
#' @author Michael Hahsler and Kurt Hornik
#' @keywords print
#' @examples
#' data("Adult")
#' rules <- apriori(Adult)
#'
#' ## display some rules
#' inspect(rules[1000:1001])
#' inspect(rules[1000:1001], ruleSep = "~~>", itemSep = " + ", setStart = "", setEnd = "",
#'   linebreak = FALSE)
#'
#' ## to get rules in readable format, use coercion or DATAFRAME with additional parameters.
#' as(rules[1000:1001], "data.frame")
#' DATAFRAME(rules[1000:1001])
#' DATAFRAME(rules[1000:1001], separate = TRUE, setStart = "", setEnd = "")
#'
setGeneric("inspect",
  function(x, ...)
    standardGeneric("inspect"))

#' @rdname inspect
setMethod("inspect", signature(x = "itemsets"),
  function(x,
    itemSep = ", ",
    setStart = "{",
    setEnd = "}",
    linebreak = NULL,
    ...) {
    n_of_itemsets <- length(x)
    
    if (n_of_itemsets == 0)
      return(invisible(NULL))
    ## Nothing to inspect here ...
    
    l <- labels(x, itemSep, setStart, setEnd)
    if (is.null(linebreak))
      linebreak <- any(nchar(l) > options("width")$width * 2 / 3)
    
    if (!linebreak) {
      out <- data.frame(items = l)
      if (nrow(quality(x)) > 0)
        out <- cbind(out, quality(x))
      rownames(out) <- paste0('[', 1:n_of_itemsets, ']')
      print(out, right = FALSE)
      
    } else {
      ## number of rows + fix empty itemsets
      items <- unlist(lapply(
        as(items(x), "list"),
        FUN = function(x)
          if (length(x) == 0)
            ""
        else
          x
      ))
      n_of_items <- size(items(x))
      n_of_items[n_of_items == 0] <- 1
      
      ## calculate begin and end positions
      entry_beg_pos <- cumsum(c(1, n_of_items[-n_of_itemsets]))
      entry_end_pos <- entry_beg_pos + n_of_items - 1
      
      ## prepare output
      n_of_rows <- sum(n_of_items)
      quality <- quality(x)
      ## Output.
      out <-
        matrix("", nrow = n_of_rows + 1, ncol = 2 + NCOL(quality))
      
      ## Column 1: itemset nr.
      tmp <- rep.int("", n_of_rows + 1)
      tmp[entry_beg_pos + 1] <- paste0('[', 1:n_of_itemsets, ']')
      out[, 1] <- format(tmp)
      
      ## Column 2: items in the item sets, one per line.
      pre <- rep.int(" ", n_of_rows)
      pre[entry_beg_pos] <- rep.int(setStart, length(entry_beg_pos))
      post <- rep.int(itemSep, n_of_rows)
      post[entry_end_pos] <- rep.int(setEnd, length(entry_end_pos))
      out[, 2] <- format(c("items",
        paste(pre, unlist(items), post, sep = "")))
      
      
      ## Remaining columns: quality measures.
      for (i in seq(length = NCOL(quality))) {
        tmp <- rep.int("", n_of_rows + 1)
        tmp[1] <- names(quality)[i]
        tmp[entry_end_pos + 1] <- format(quality[[i]])
        out[, i + 2] <- format(tmp, justify = "right")
      }
      
      ## Output.
      cat(t(out), sep = c(rep.int(" ", NCOL(out) - 1), "\n"))
    }
  })

#' @rdname inspect
setMethod("inspect", signature(x = "rules"),
  function(x,
    itemSep = ", ",
    setStart = "{",
    setEnd = "}",
    ruleSep = "=>",
    linebreak = NULL,
    ...) {
    n_of_rules <- length(x)
    
    if (n_of_rules == 0)
      return(invisible(NULL))
    ## Nothing to inspect here ...
    
    lhs <- labels(lhs(x), itemSep, setStart, setEnd)
    rhs <- labels(rhs(x), itemSep, setStart, setEnd)
    
    if (is.null(linebreak))
      linebreak <- any(nchar(lhs) + nchar(rhs) + nchar(ruleSep) >
          options("width")$width * 2 / 3)
    
    if (!linebreak) {
      out <- data.frame(lhs = lhs, "." = ruleSep, rhs = rhs)
      if (nrow(quality(x)) > 0)
        out <- cbind(out, quality(x))
      colnames(out)[2] <- ""
      rownames(out) <- paste0('[', 1:n_of_rules, ']')
      print(out, right = FALSE)
      
    } else {
      items_lhs <- as(lhs(x), "list")
      items_rhs <- as(rhs(x), "list")
      
      ### Empty RHS!
      items_rhs <- lapply(
        items_rhs,
        FUN = function(r)
          if (length(r) == 0)
            ""
        else
          r
      )
      
      quality <- quality(x)
      
      ## Rewrite empty LHSs.
      ind <- sapply(items_lhs, length) == 0
      if (any(ind))
        items_lhs[ind] <- ""
      
      ## Various lengths ...
      n_of_items_lhs <- sapply(items_lhs, length)
      n_of_items_rhs <- sapply(items_rhs, length)
      entry_end_pos <-
        cumsum(n_of_items_lhs + n_of_items_rhs - 1) + 1
      entry_beg_pos <- c(1, entry_end_pos[-n_of_rules]) + 1
      entry_mid_pos <- entry_beg_pos + n_of_items_lhs - 1
      lhs_pos <- unlist(mapply(seq, entry_beg_pos, entry_mid_pos,
        SIMPLIFY = FALSE))
      rhs_pos <- unlist(mapply(seq, entry_mid_pos, entry_end_pos,
        SIMPLIFY = FALSE))
      n_of_rows <- entry_end_pos[n_of_rules]
      
      out <- matrix("", nrow = n_of_rows, ncol = 4 + NCOL(quality))
      
      ## Column 1: Rule number
      tmp <- rep.int("", n_of_rows)
      tmp[entry_beg_pos] <- paste0('[', 1:n_of_rules, ']')
      out[, 1] <- format(tmp)
      
      ## Column 2: lhs.
      pre <- rep.int(" ", n_of_rows)
      pre[entry_beg_pos] <- setStart
      post <- rep.int("", n_of_rows)
      post[lhs_pos] <- itemSep
      post[entry_mid_pos] <- setEnd
      tmp <- rep.int("", n_of_rows)
      tmp[lhs_pos] <- unlist(items_lhs)
      out[, 2] <-
        format(c("lhs", paste(pre, tmp, post, sep = "")[-1]))
      
      ## Column 3: '=>'
      tmp <- rep.int("", n_of_rows)
      tmp[entry_mid_pos] <- ruleSep
      out[, 3] <- format(tmp)
      
      ## Column 4: rhs.
      pre <- rep.int(" ", n_of_rows)
      pre[entry_mid_pos] <- setStart
      post <- rep.int("", n_of_rows)
      post[rhs_pos] <- itemSep
      post[entry_end_pos] <- setEnd
      tmp <- rep.int("", n_of_rows)
      tmp[rhs_pos] <- unlist(items_rhs)
      out[, 4] <-
        format(c("rhs", paste(pre, tmp, post, sep = "")[-1]))
      
      ## Remaining columns: quality measures.
      for (i in seq(length = NCOL(quality))) {
        tmp <- rep.int("", n_of_rows)
        tmp[1] <- names(quality)[i]
        tmp[entry_end_pos] <- format(quality[[i]])
        out[, i + 4] <- format(tmp, justify = "right")
      }
      ## Output.
      cat(t(out), sep = c(rep.int(" ", NCOL(out) - 1), "\n"))
    }
  })


#' @rdname inspect
setMethod("inspect", signature(x = "transactions"),
  function(x,
    itemSep = ", ",
    setStart = "{",
    setEnd = "}",
    linebreak = NULL,
    ...) {
    n_of_itemsets <- length(x)
    
    if (n_of_itemsets == 0)
      return(invisible(NULL))
    ## Nothing to inspect here ...
    
    l <- labels(x, itemSep, setStart, setEnd)
    if (is.null(linebreak))
      linebreak <- any(nchar(l) > options("width")$width * 2 / 3)
    
    if (!linebreak) {
      out <- data.frame(items = l)
      if (nrow(transactionInfo(x)) > 0)
        out <- cbind(out, transactionInfo(x))
      rownames(out) <- paste0('[', 1:n_of_itemsets, ']')
      print(out, right = FALSE)
      
    } else {
      ## number of rows + fix empty itemsets
      items <- unlist(lapply(
        as(x, "list"),
        FUN = function(x)
          if (length(x) == 0)
            ""
        else
          x
      ))
      n_of_items <- size(x)
      n_of_items[n_of_items == 0] <- 1
      
      ## calculate begin and end positions
      entry_beg_pos <- cumsum(c(1, n_of_items[-n_of_itemsets]))
      entry_end_pos <- entry_beg_pos + n_of_items - 1
      
      ## prepare output
      n_of_rows <- sum(n_of_items)
      transactionInfo <- transactionInfo(x)
      ## Output.
      out <-
        matrix("",
          nrow = n_of_rows + 1,
          ncol = 2 + NCOL(transactionInfo))
      
      ## Column 1: itemset nr.
      tmp <- rep.int("", n_of_rows + 1)
      tmp[entry_beg_pos + 1] <- paste0('[', 1:n_of_itemsets, ']')
      out[, 1] <- format(tmp)
      
      ## Column 2: items in the item sets, one per line.
      pre <- rep.int(" ", n_of_rows)
      pre[entry_beg_pos] <- rep.int(setStart, length(entry_beg_pos))
      post <- rep.int(itemSep, n_of_rows)
      post[entry_end_pos] <- rep.int(setEnd, length(entry_end_pos))
      out[, 2] <- format(c("items",
        paste(pre, unlist(items), post, sep = "")))
      
      
      ## Remaining columns: transactionInfo.
      for (i in seq(length = NCOL(transactionInfo))) {
        tmp <- rep.int("", n_of_rows + 1)
        tmp[1] <- names(transactionInfo)[i]
        tmp[entry_end_pos + 1] <- format(transactionInfo[[i]])
        out[, i + 2] <- format(tmp, justify = "right")
      }
      
      ## Output.
      cat(t(out), sep = c(rep.int(" ", NCOL(out) - 1), "\n"))
    }
    
  })

#' @rdname inspect
setMethod("inspect", signature(x = "itemMatrix"),
  function(x,
    itemSep = ", ",
    setStart = "{",
    setEnd = "}",
    linebreak = NULL,
    ...) {
    n_of_itemsets <- length(x)
    
    if (n_of_itemsets == 0)
      return(invisible(NULL))
    ## Nothing to inspect here ...
    
    l <- labels(x, itemSep, setStart, setEnd)
    if (is.null(linebreak))
      linebreak <- any(nchar(l) > options("width")$width * 2 / 3)
    
    if (!linebreak) {
      out <- data.frame(items = l)
      rownames(out) <- paste0('[', 1:n_of_itemsets, ']')
      print(out, right = FALSE)
      
    } else {
      items <- unlist(lapply(
        as(x, "list"),
        FUN = function(x)
          if (length(x) == 0)
            ""
        else
          x
      ))
      
      n_of_items <- size(x)
      n_of_items[n_of_items == 0] <- 1
      
      ## calculate begin and end positions
      entry_beg_pos <- cumsum(c(1, n_of_items[-n_of_itemsets]))
      entry_end_pos <- entry_beg_pos + n_of_items - 1
      
      ## prepare output
      n_of_rows <- sum(n_of_items)
      ## Output.
      out <- matrix("", nrow = n_of_rows + 1, ncol = 2)
      
      ## Column 1: itemset nr.
      tmp <- rep.int("", n_of_rows + 1)
      tmp[entry_beg_pos + 1] <- paste0('[', 1:n_of_itemsets, ']')
      out[, 1] <- format(tmp)
      
      ## Column 2: items in the item sets, one per line.
      pre <- rep.int(" ", n_of_rows)
      pre[entry_beg_pos] <- rep.int(setStart, length(entry_beg_pos))
      post <- rep.int(itemSep, n_of_rows)
      post[entry_end_pos] <- rep.int(setEnd, length(entry_end_pos))
      out[, 2] <- format(c("items",
        paste(pre, unlist(items), post, sep = "")))
      
      
      ## Output.
      cat(t(out), sep = c(rep.int(" ", NCOL(out) - 1), "\n"))
    }
  })


#' @rdname inspect
setMethod("inspect", signature(x = "tidLists"),
  function(x, ...) {
    print(data.frame(
      items = itemLabels(x),
      transactionIDs = labels(x),
      row.names = NULL
    ),
      right = FALSE)
  })