R/Noisy.R

In ralmond/CPTtools: Tools for Creating Conditional Probability Tables

## These are functions related to noisy-and/ noisy-or &c.


calcNoisyAndTable <-
  function (skillLevels,obsLevels=c("True","False"),
            bypass=rep(0,length(skillLevels)),noSlip=1,
            thresholds = sapply(skillLevels,function(states) states[1])) {
  pdims <- sapply(skillLevels,length)
  ## Logical values indicating if each value has met the threshold.
  svals <- vector("list",length(skillLevels))
  for (j in 1:length(skillLevels)) {
    svals[[j]] <- rev(cumsum(rev(skillLevels[[j]]==thresholds[j])))
  }
  ss <- as.matrix(do.call("expand.grid",svals))
  rr <- sweep(ss,2,bypass,function(s,r) ifelse(s,1,r))
  probs <- noSlip*apply(rr,1,prod)
  probs <- cbind(probs,1-probs)
  colnames(probs)<-obsLevels
  probs
}

calcNoisyAndFrame <-
  function (skillLevels,obsLevels=c("True","False"),
            bypass=rep(0,length(skillLevels)),noSlip=1,
            thresholds = sapply(skillLevels,function(states) states[1])) {
  result <- data.frame(expand.grid(skillLevels),
                       calcNoisyAndTable(skillLevels,paste(obsLevels),
                                         bypass,noSlip,thresholds))
  if (is.numeric(obsLevels) ||
      names(result)[length(skillLevels)+1]!=paste(obsLevels[1])) {
    ## R is "helpfully" fixing our numeric labels.  Need to insist.
    names(result) <- c(names(skillLevels),paste(obsLevels))
  }
  result
}

calcNoisyOrTable <- function (skillLevels,obsLevels=c("True","False"),
                              suppression=rep(0,length(skillLevels)),noGuess=1,
                              thresholds = sapply(skillLevels,function(states) states[1]))
{
  pdims <- sapply(skillLevels,length)
  ## Logical values indicating if each value has met the threshold.
  svals <- vector("list",length(skillLevels))
  for (j in 1:length(skillLevels)) {
    svals[[j]] <- rev(cumsum(rev(skillLevels[[j]]==thresholds[j])))
  }
  ss <- as.matrix(do.call("expand.grid",svals))
  qq <- sweep(ss,2,suppression,function(s,q) ifelse(s,q,1))
  probs <-   1-noGuess*apply(qq,1,prod)
  probs <- cbind(probs,1-probs)
  colnames(probs)<-obsLevels
  probs
}

calcNoisyOrFrame <-
  function (skillLevels,obsLevels=c("True","False"),
            suppression=rep(0,length(skillLevels)),noGuess=1,
            thresholds = sapply(skillLevels,function(states) states[1])) {
  result <- data.frame(expand.grid(skillLevels),
                       calcNoisyOrTable(skillLevels,paste(obsLevels),
                                         suppression,noGuess,thresholds))
  if (is.numeric(obsLevels) ||
      names(result)[length(skillLevels)+1]!=paste(obsLevels[1])) {
    ## R is "helpfully" fixing our numeric labels.  Need to insist.
    names(result) <- c(names(skillLevels),paste(obsLevels))
  }
  result
}