R/clamp.R

In CRF: Conditional Random Fields

#' Make clamped CRF
#' 
#' Generate clamped CRF by fixing the states of some nodes
#' 
#' The function will generate a clamped CRF from a given CRF
#' by fixing the states of some nodes. The vector \code{clamped}
#' contains the desired state for each node while zero means the state is not
#' fixed. The node and edge potentials are updated to the conditional
#' potentials based on the clamped vector.
#' 
#' @param crf The CRF generated by \code{\link{make.crf}}
#' @param clamped The vector of fixed states of nodes
#' @return The function will return a new CRF with additional components: 
#'   \item{original}{The original CRF.} 
#'   \item{clamped}{The vector of fixed states of nodes.} 
#'   \item{node.id}{The vector of the original node ids for nodes in the new CRF.} 
#'   \item{node.map}{The vector of the new node ids for nodes in the original CRF.} 
#'   \item{edge.id}{The vector of the original edge ids for edges in the new CRF.} 
#'   \item{edge.map}{The vector of the new edge ids for edges in the original CRF.}
#' @seealso \code{\link{make.crf}}, \code{\link{sub.crf}}, \code{\link{clamp.reset}}
#' @examples
#' 
#' library(CRF)
#' data(Small)
#' crf <- clamp.crf(Small$crf, c(0, 0, 1, 1))
#' 
#' 
#' @export
clamp.crf <- function(crf, clamped)
{
	data <- new.env()
	if (!is.vector(clamped) || length(clamped) != crf$n.nodes)
		stop("'clamped' should be a vector of length ", crf$n.nodes, "!")
	if (any(clamped > crf$n.states | clamped < 0))
		stop("'clamped' has invalid value(s)!")

	data$original <- crf
	data$clamped <- clamped

	data$node.id <- which(clamped == 0)
	data$n.nodes <- length(data$node.id)
	data$node.map <- rep(0, crf$n.nodes)
	data$node.map[data$node.id] <- 1:data$n.nodes

	data$edge.id <- which(clamped[crf$edges[,1]] == 0 & clamped[crf$edges[,2]] == 0)
	data$n.edges <- length(data$edge.id)
	data$edges <- matrix(data$node.map[crf$edges[data$edge.id,]], ncol=2)
	data$edge.map <- rep(0, crf$n.edges)
	data$edge.map[data$edge.id] <- 1:data$n.edges

	.Call(Make_AdjInfo, data)

	data$n.states <- crf$n.states[data$node.id]
	data$max.state <- max(data$n.states)

	data$node.pot <- crf$node.pot[data$node.id, 1:data$max.state]
	data$edge.pot <- crf$edge.pot[data$edge.id]
	.Call(Clamp_Reset, data)

	class(data) <- c("CRF.clamped", "CRF")
	data
}



#' Reset clamped CRF
#' 
#' Reset clamped CRF by changing the states of clamped nodes
#' 
#' The function will reset a clamped CRF by changing the states of fixed nodes.
#' The vector \code{clamped} contains the desired state for each node 
#' while zero means the state is not fixed. The node and edge potentials are 
#' updated to the conditional potentials based on the clamped vector.
#' 
#' @param crf The clamped CRF generated by \code{\link{clamp.crf}}
#' @param clamped The vector of fixed states of nodes
#' @return The function will return the same clamped CRF.
#' @seealso \code{\link{make.crf}}, \code{\link{clamp.crf}}
#' @examples
#' 
#' library(CRF)
#' data(Small)
#' crf <- clamp.crf(Small$crf, c(0, 0, 1, 1))
#' clamp.reset(crf, c(0,0,2,2))
#' 
#' 
#' @export
clamp.reset <- function(crf, clamped)
{
	if (is.na(class(crf)[1]) || class(crf)[1] != "CRF.clamped")
		stop("'crf' is not class CRF.clamped!")
	if (sum(xor(crf$clamped == 0, clamped == 0)) != 0)
		stop("'clamped' has different clamped structure!")
	if (any(clamped > crf$original$n.states | clamped < 0))
		stop("'clamped' has invalid clamped value(s)!")
	crf$clamped <- clamped
	.Call(Clamp_Reset, crf)
	crf
}



#' Make sub CRF
#' 
#' Generate sub CRF by selecting some nodes
#' 
#' The function will generate a new CRF from a given CRF
#' by selecting some nodes. The vector \code{subset} contains the
#' node ids selected to generate the new CRF. Unlike
#' \code{\link{clamp.crf}}, the potentials of remainning nodes and edges are
#' untouched.
#' 
#' @param crf The CRF generated by \code{\link{make.crf}}
#' @param subset The vector of selected node ids
#' @return The function will return a new CRF with additional components: 
#'   \item{original}{The original CRF data.} 
#'   \item{node.id}{The vector of the original node ids for nodes in the new CRF.}
#'   \item{node.map}{The vector of the new node ids for nodes in the original CRF.} 
#'   \item{edge.id}{The vector of the original edge ids for edges in the new CRF.} 
#'   \item{edge.map}{The vector of the new edge ids for edges in the original CRF.}
#' @seealso \code{\link{make.crf}}, \code{\link{clamp.crf}}
#' @examples
#' 
#' library(CRF)
#' data(Small)
#' crf <- sub.crf(Small$crf, c(2, 3))
#' 
#' 
#' @export
sub.crf <- function(crf, subset)
{
	data <- new.env()
	data$original <- crf

	data$node.id <- intersect(1:crf$n.nodes, unique(subset))
	data$n.nodes <- length(data$node.id)
	data$node.map <- rep(0, crf$n.nodes)
	data$node.map[data$node.id] <- 1:data$n.nodes

	data$edge.id <- which(data$node.map[crf$edges[,1]] != 0 & data$node.map[crf$edges[,2]] != 0)
	data$n.edges <- length(data$edge.id)
	data$edges <- matrix(data$node.map[crf$edges[data$edge.id,]], ncol=2)
	data$edge.map <- rep(0, crf$n.edges)
	data$edge.map[data$edge.id] <- 1:data$n.edges

	adj.info <- .Call(Make_AdjInfo, data)
	data$n.adj <- adj.info$n.adj
	data$adj.nodes <- adj.info$adj.nodes
	data$adj.edges <- adj.info$adj.edges

	data$n.states <- crf$n.states[data$node.id]
	data$max.state <- max(data$n.states)

	data$node.pot <- array(crf$node.pot[data$node.id, 1:data$max.state], dim=c(data$n.nodes, data$max.state))
	data$edge.pot <- crf$edge.pot[data$edge.id]

	class(data) <- c("CRF.sub", "CRF")
	data
}