R/assoc_data.R

In exams.forge: Support for Compiling Examination Tasks using the 'exams' Package

#' @rdname assoc_data
#' @aliases reorder_association_data
#' @aliases dassoc
#' @title Frequency Optimization
#' @description Given a frequency table, the function reorders the observations such that the given `target` association will be approximated and the marginal
#' frequencies remain unchanged. Note that the `target` association may not be reached!
#' \code{zero} allows for zero entries in the common distribution.
#' If \code{target} is \code{NA} then the table is simply returned. \code{FUN} computes the association (or correlation) measure based on a
#' frequency table. \code{tol} gives the maximal deviation of the association (or correlation) measure
#' and the \code{target} value. \code{maxit} limits the number of steps.
#' Please note that a solution is not guaranteed, especially for extreme values of \code{target}, for example
#' for \eqn{+1}, \eqn{-1} or nearby values.
#' If `attr(joint, "iterations")== maxit` then you need either to increase \code{maxit}, to decrease \code{tol}, or 
#' check if you have chosen an appropriate \code{target} value (for a nominal measure in \eqn{0 <= target <= 1}, for ordinal measure in \eqn{-1 <= target <= +1}).
#' \code{attr(joint, "target")} contains the achieved association.
#'
#' @param tab table: table of absolute frequencies
#' @param zero logical: zeros are allowed in the final probabilities (default: \code{FALSE})
#' @param FUN function: association or correlation function (default: \code{nom.cc})
#' @param target numeric: target association or correlation (default: \code{NA})
#' @param tol numeric: tolerance for target association or correlation (default: \code{0.001})
#' @param maxit integer: maximal number of iterations (default: \code{100})
#' @param ... further parameters
#' 
#' @return a modified frequency table
#' @export
#'
#' @examples
#' tab <- table_data(3, 2)
#' tab
#' tab2 <- assoc_data(tab, target=0.5)
#' tab2
assoc_data <- function(tab, zero=FALSE, FUN=nom.cc, target=NA, tol=0.001, maxit=500, ...) {
  stopifnot(!is.null(dim(tab)))
  it   <- 0
  fun  <- match.fun(FUN)
  curr <- fun(tab, ...)
  if (!is.na(target)) {
    #browser()
    d    <- abs(curr-target)
    if (!equal(d,0, tol)) {
      n  <- sum(tab)
      while(it<maxit) {
        i    <- sample(nrow(tab), size=2)
        j    <- sample(ncol(tab), size=2)
        tabt <- tab
        tabt[i[1], j[1]] <- tabt[[i[1], j[1]]]+1
        tabt[i[1], j[2]] <- tabt[[i[1], j[2]]]-1
        tabt[i[2], j[1]] <- tabt[[i[2], j[1]]]-1
        tabt[i[2], j[2]] <- tabt[[i[2], j[2]]]+1
        doit <- all(if (zero) (tabt[i,j]>=0) else (tabt[i,j]>0), tabt[i,j]<=n)
        if (doit) {
          curr <- fun(tabt, ...)
          dt   <- abs(curr-target)
          if (dt<d) {
            d    <- dt
            tab  <- tabt
            if (equal(d,0, tol)) break
          }
        }
        it <- it+1
      }
    }
  }
  structure(tab, iterations=it, target=fun(tab, ...))
}
#' @rdname assoc_data
#' @export reorder_association_data
# reorder_association_data <- function(...){assoc_data(...)}
reorder_association_data <- assoc_data

#' @rdname assoc_data
#' @export dassoc
# dassoc <- function(...){assoc_data(...)}
dassoc <- assoc_data