R/match.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.

#' Value Matching
#'
#' Provides the generic function `match()` and the methods for
#' [associations], [transactions] and [itemMatrix] objects.  `match()` returns a vector
#' of the positions of (first) matches of its first argument in its second.
#'
#' `%in%` is a more intuitive interface as a binary operator, which
#' returns a logical vector indicating if there is a match or not for the items
#' in the itemsets (left operand) with the items in the table (right operand).
#'
#' \pkg{arules} defines additional binary operators for matching itemsets:
#' `%pin%` uses _partial matching_ on the table; `%ain%`
#' itemsets have to match/include _all_ items in the table; `%oin%`
#' itemsets can _only_ match/include the items in the table.  The binary
#' matching operators or often used in [subset()].
#'
#' @aliases match
#' @family associations functions
#' @family itemMatrix and transactions functions
#' 
#' @param x an object of class [itemMatrix], [transactions] or
#' [associations].
#' @param table a set of associations or transactions to be matched against.
#' @param nomatch the value to be returned in the case when no match is found.
#' @param incomparables not implemented.
#' @return `match`: An integer vector of the same length as `x`
#' giving the position in `table` of the first match if there is a match,
#' otherwise `nomatch`.
#'
#' `%in%`, `%pin%`, `%ain%`, `%oin%`: A logical vector,
#' indicating if a match was located for each element of `x`.
#' @author Michael Hahsler
#' @keywords manip
#' @examples
#' data("Adult")
#'
#' ## get unique transactions, count frequency of unique transactions
#' ## and plot frequency of unique transactions
#' vals <- unique(Adult)
#' cnts <- tabulate(match(Adult, vals))
#' plot(sort(cnts, decreasing=TRUE))
#'
#' ## find all transactions which are equal to transaction 10 in Adult
#' which(Adult %in% Adult[10])
#'
#' ## for transactions we can also match directly with itemLabels.
#' ## Find in the first 10 transactions the ones which
#' ## contain age=Middle-aged (see help page for class itemMatrix)
#' Adult[1:10] %in% "age=Middle-aged"
#'
#' ## find all transactions which contain items that partially match "age=" (all here).
#' Adult[1:10] %pin% "age="
#'
#' ## find all transactions that only include the item "age=Middle-aged" (none here).
#' Adult[1:10] %oin% "age=Middle-aged"
#'
#' ## find al transaction which contain both items "age=Middle-aged" and "sex=Male"
#' Adult[1:10] %ain% c("age=Middle-aged", "sex=Male")
setGeneric("match")

#' @rdname match
setMethod("match", signature(x = "itemMatrix", table = "itemMatrix"),
  function(x,
    table,
    nomatch = NA_integer_,
    incomparables = NULL) {
    if (!compatible(x, table)) {
      warning("Item coding not compatible, recoding item matrices first.")
      
      k <- match(itemLabels(x), itemLabels(table))
      n <- which(is.na(k))
      if (length(n)) {
        k[n] <- table@data@Dim[1] + seq(length(n))
        table@data@Dim[1] <- table@data@Dim[1] + length(n)
      }
      if (any(k != seq_len(length(k))))
        x@data <- .Call(R_recode_ngCMatrix, x@data, k)
      if (x@data@Dim[1] <  table@data@Dim[1])
        x@data@Dim[1] <- table@data@Dim[1]
    }
    
    i <- .Call(R_pnindex, table@data, x@data, FALSE)
    match(i,
      seq_len(length(table)),
      nomatch = nomatch,
      incomparables = incomparables)
  })

#' @rdname match
setMethod("match", signature(x = "rules", table = "rules"),
  function(x,
    table,
    nomatch = NA_integer_,
    incomparables = NULL)
    match(
      .joinedList(x),
      .joinedList(table),
      nomatch = nomatch,
      incomparables = incomparables
    ))

#' @rdname match
setMethod("match", signature(x = "itemsets", table = "itemsets"),
  function(x,
    table,
    nomatch = NA_integer_,
    incomparables = NULL)
    match(
      x@items,
      table@items,
      nomatch = nomatch,
      incomparables = incomparables
    ))

## find elements which contain some items (as labels or
## in itemInfo) note this is not what we would expect for
## %in% in R! but match below works the R-way

setGeneric("%in%")

#' @rdname match
#' @aliases %in%
setMethod("%in%", signature(x = "itemMatrix", table = "itemMatrix"),
  function(x, table)
    ! is.na(match(x, table)))

#' @rdname match
setMethod("%in%", signature(x = "itemMatrix", table = "character"),
  function(x, table) {
    pos <- match(table, itemLabels(x))
    if (any(is.na(pos)))
      stop("table contains an unknown item label")
    size(x[, pos]) > 0
  })

#' @rdname match
setMethod("%in%", signature(x = "associations", table = "associations"),
  function(x, table)
    match(x, table))

# partial in

setGeneric("%pin%",
  function(x, table) standardGeneric("%pin%"))

#' @rdname match
#' @aliases %pin%
setMethod("%pin%", signature(x = "itemMatrix", table = "character"),
  function(x, table) {
    if (length(table) > 1) {
      warning("table contains more than one item label pattern and only the first element will be used")
      table <- table[1]
    }
    
    if (table[1] == "")
      stop("table contains an illegal pattern (empty string)")
    
    pos <- grep(table, itemLabels(x))
    
    if (is.na(pos[1]))
      return(rep(FALSE, length(x)))
    
    size(x[, pos]) > 0
  })


# all in

setGeneric("%ain%",
  function(x, table) standardGeneric("%ain%"))

#' @rdname match
#' @aliases %ain%
setMethod("%ain%", signature(x = "itemMatrix", table = "character"),
  function(x, table) {
    pos <- match(table, itemLabels(x))
    if (any(is.na(pos)))
      stop("table contains an unknown item label")
    size(x[, pos]) == length(pos)
  })

## only items can to be in

setGeneric("%oin%",
  function(x, table) standardGeneric("%oin%"))

#' @rdname match
#' @aliases %oin%
setMethod("%oin%", signature(x = "itemMatrix", table = "character"),
  function(x, table) {
    pos <- match(table, itemLabels(x))
    if (any(is.na(pos)))
      stop("table contains an unknown item label")
    size(x[, -pos]) == 0
  })