R/impreciseEstimationConditional.R

In impimp: Imprecise Imputation for Statistical Matching

# Copyright (C) 2018  Paul Fink, Eva Endres
#
# This file is part of impimp.
#
# imptree 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
# (at your option) any later version.
#
# imptree 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 imptree.  If not, see <https://www.gnu.org/licenses/>.

#' @title Conditional Imprecise Estimation
#'
#' @description Estimate conditional probability of some events
#' based on data obtained by imprecise imputation
#'
#' @param data a data.frame obtained as result from an
#' imprecise imputation e.g. by a call to
#' \code{\link{impimp}}.
#' @param event a list of objects of class \code{"impimp_event"},
#' specifiying the event of interest. See 'Details'.
#' @param condition a list of objects of class \code{"impimp_event"},
#' specifiying the event to condition on. See 'Details'.
#' @param constraints a list of so-called logical constraints or
#' fixed zeros. Each element must be an object of class
#' \code{"impimp_event"}. See 'Details' .
#'
#' @return A numeric vector of length 2, where the
#' first component contains the lower and the second component
#' the upper conditional probability of the event of interest.
#'
#' @details
#' \code{event} and \code{condition} should each be a list of objects
#' of class \code{"impmp_event"}, where within each list the set union
#' of impimp_events is the actual event of interest or conditioning
#' event, respectively.
#'
#' By specifying \code{constraints} one can exlude combinations of
#' imputed values which are deemed impossible, so called
#' \sQuote{logical constraints} or \sQuote{fixed zeros}.
#' \code{constraints} should be a list of objects of class
#' \code{"impimp_event"}.
#'
#' An object of class \code{"impimp_event"} is obtained as a result
#' of a call to \code{\link{impimp_event}}.
#'
#' For \code{event}, \code{condition} and \code{constraints} holds
#' that overlapping in the resulting events generated by the
#' individual impimp_events does not have any side effects, besides
#' a potential decrease in performance.
#'
#' @keywords robust
#'
#' @references Dubois, D. and Prade, H. (1992), Evidence, knowledge,
#' and belief functions, \emph{International Journal of Approximate
#' Reasoning} \bold{6}(3), 295–319.
#'
#' @seealso \code{\link{impimp}}, \code{\link{impimp_event}} for
#' sepcifying constraints and events; \code{\link{impest}} for
#' the estimation of unconditional probabilities
#'
#' @examples
#' A <- data.frame(x1 = c(1,0), x2 = c(0,0),
#'                 y1 = c(1,0), y2 = c(2,2))
#' B <- data.frame(x1 = c(1,1,0), x2 = c(0,0,0),
#'                 z1 = c(0,1,1), z2 = c(0,1,2))
#' AimpB <- impimp(A, B, method = "domain")
#' BimpA <- impimp(B, A, method = "domain")
#' AB <- rbindimpimp(AimpB, BimpA)
#'
#' myevent <- list(impimp_event(z1 = 1,z2 = 0),
#'                 impimp_event(z1 = c(0,1), z2 = 1))
#' cond <- list(impimp_event(x1 = 1))
#'
#' impestcond(AB, event = myevent, condition = cond)
#'
#' constr <- list(impimp_event(y1 = 0, z1 = 0))
#' impestcond(AB, event = myevent, condition = cond,
#'            constraints = constr)
#'
#' @export

impestcond <- function(data, event, condition, constraints = NULL) {

  if(!is.impimp(data)) {
    stop(gettextf("conditional imprecise estimation is only meaningful for objects of class %s",
                  dQuote("impimp"), domain = "R-impimp"))
  }
  eventcheck(event)
  eventcheck(condition)

  # make all events and conditions equal by unlisting them
  event <- unlist(event, recursive = FALSE)
  condition <- unlist(condition, recursive = FALSE)

  # generate the tupel data, including the constraints
  tupelData <- generateTupelData(data, constraints)

  # Compatible subset of the condition
  compSubsetCond <- vapply(tupelData, function(data) {
    sum(evalConditions(condition, data))
  }, FUN.VALUE = integer(1L))

  # if no tupel data is compatible with the condition raise error
  if(!any(compSubsetCond)) {
    stop(gettextf("the lower probability of %s needs to be strictly larger than 0",
                  sQuote("condition"), domain = "R-impimp"))
  }

  # compatible subset of the event
  compSubsetEvent <- vapply(tupelData, function(data) {
    sum(evalConditions(event, data))
  }, FUN.VALUE = integer(1L))

  # lengths of the individual tupel data
  overallTupels <- sapply(tupelData, NROW)

  # compatible subset of the complemental event
  compSubsetCompEvent <- overallTupels - compSubsetEvent

  # unnormalized belief of condtion and event
  BelCondEvent <- sum((compSubsetEvent == overallTupels) &
    (compSubsetCond == overallTupels) &
    (overallTupels))

  # unnormalized belief of condtion and complemental event
  BelCondCompEvent <- sum((compSubsetCompEvent == overallTupels) &
    (compSubsetCond == overallTupels) &
    (overallTupels))

  # unnormalized plausibility of condtion and event
  PlCondEvent <- sum((compSubsetEvent * compSubsetCond) > 0)
  # unnormalized plausibility of condtion and complemental event
  PlCondCompEvent <- sum((compSubsetCompEvent * compSubsetCond) > 0)

  # calculation of lower and upper conditional probability
  lower <- BelCondEvent / (BelCondEvent + PlCondCompEvent)
  upper <- PlCondEvent / (PlCondEvent + BelCondCompEvent)

  # return belief and plausibility
  return(c(lower, upper))
}