R/set_boundaries.R

In ipeglim: Imprecise Inferential Framework on Statistical Reasoning

#' Add points on boundaries of a convex hull
#'
#' \code{add.bounaries} uses xy-coordinate information of extreme
#' points of a convex hull which is obtained from the use of
#' \code{iprior}.
#' 
#' @note In order to add points in a convex hull with a set of given
#' extreme points which is obtained from \code{iprior}, a
#' function \code{set.grid} can be used.  However, the use of
#' \code{set.grid} should be followed by the use of
#'
#' @author Chel Hee Lee <\email{gnustats@@gmail.com}>
#' 
#' @param obj a list which is returend from \code{iprior}.
#' @param ... other arguments
#' 
#' @export
add.boundaries <- function(obj, ...) {
  UseMethod("add.boundaries")
}
NULL

#' @rdname add.boundaries
#' @param len a scalar, a number of points which will be added on
#' boundaries is by default 5.
#' @method add.boundaries imprecise
add.boundaries.imprecise <- function(obj, len=5, ...){

  m0shape <- obj$m0shape
  if(m0shape == "eqns3d") stop("Not implemented yet")
  
#  if(any(attr(obj, "class") == "addInteriors"))
#  stop("Suggested to use 'addOnBounaries' prior to 'addInteriors'")

  obj$xtms0 <- xtms <- obj$xtms
  xtms <- xtms[chull(xtms),]

  lc.pairs <- combn(seq_len(nrow(xtms)), 2)
  lc.pairs <- lc.pairs[, !duplicated(lc.pairs[1,])]
  lc.pairs <- cbind(lc.pairs, c(nrow(xtms),1))

  fnTmp <- function(i, ...){
    idx <- as.vector(lc.pairs[,i])
    p1 <- as.vector(xtms[idx[1],])
    p2 <- as.vector(xtms[idx[2],])
    pDiff <- p1-p2

    if( (pDiff[1] == 0) && (pDiff[2] != 0) ) rpoints <-
    cbind(rep(p1[1], len), seq(p1[2], p2[2], length.out=len))
    if( (pDiff[1] != 0) && (pDiff[2] == 0) ) rpoints <-
    cbind(seq(p1[1], p2[1], length.out=len), rep(p1[2], len))
    if( (pDiff[1] != 0) && (pDiff[2] != 0) ){
      xx <- seq(p1[1], p2[1], length.out=len)
      rpoints <- cbind(xx, (pDiff[2]/pDiff[1])*(xx-p2[1]) + p2[2])
    }

    dimnames(rpoints) <- NULL
    return(rpoints)
  }

  tmp <- lapply(seq_len(ncol(lc.pairs)), fnTmp)
  pts <- do.call(rbind, tmp)

  bounds <- rbind(pts, xtms)
  bounds <- bounds[!duplicated(bounds),]
  obj$xtms <- obj$bounds <- bounds
  
#  class(obj) <- c(attr(obj, "class"), "addOnBoundaries")
  return(obj)
} # End of addOnBoundaries
NULL

# NOTE:
# visualization will be difficult if points on boundaries are added.
#