Nothing
#' Decoding method for small graphs
#'
#' Computing the most likely configuration for CRF
#'
#' Exact decoding for small graphs with brute-force search
#'
#' @param crf The CRF
#' @return This function will return the most likely configuration, which is a vector of length \code{crf$n.nodes}.
#'
#' @examples
#'
#' library(CRF)
#' data(Small)
#' d <- decode.exact(Small$crf)
#'
#' @export
decode.exact <- function(crf)
.Call(Decode_Exact, crf)
#' Decoding method for chain-structured graphs
#'
#' Computing the most likely configuration for CRF
#'
#' Exact decoding for chain-structured graphs with the Viterbi algorithm.
#'
#' @param crf The CRF
#' @return This function will return the most likely configuration, which is a vector of length \code{crf$n.nodes}.
#'
#' @examples
#'
#' library(CRF)
#' data(Small)
#' d <- decode.chain(Small$crf)
#'
#' @export
decode.chain <- function(crf)
.Call(Decode_Chain, crf)
#' Decoding method for tree- and forest-structured graphs
#'
#' Computing the most likely configuration for CRF
#'
#' Exact decoding for tree- and forest-structured graphs with max-product belief propagation
#'
#' @param crf The CRF
#' @return This function will return the most likely configuration, which is a vector of length \code{crf$n.nodes}.
#'
#' @examples
#'
#' library(CRF)
#' data(Small)
#' d <- decode.tree(Small$crf)
#'
#' @export
decode.tree <- function(crf)
.Call(Decode_Tree, crf)
#' Conditional decoding method
#'
#' Computing the most likely configuration for CRF
#'
#' Conditional decoding (takes another decoding method as input)
#'
#' @param crf The CRF
#' @param clamped The vector of fixed values for clamped nodes, 0 for unfixed nodes
#' @param decode.method The decoding method to solve clamped CRF
#' @param ... The parameters for \code{decode.method}
#' @return This function will return the most likely configuration, which is a vector of length \code{crf$n.nodes}.
#'
#' @examples
#'
#' library(CRF)
#' data(Small)
#' d <- decode.conditional(Small$crf, c(0,1,0,0), decode.exact)
#'
#' @export
decode.conditional <- function(crf, clamped, decode.method, ...)
{
newcrf <- clamp.crf(crf, clamped)
decode <- clamped
decode[newcrf$node.id] <- decode.method(newcrf, ...)
decode
}
#' Decoding method for graphs with a small cutset
#'
#' Computing the most likely configuration for CRF
#'
#' Exact decoding for graphs with a small cutset using cutset conditioning
#'
#' @param crf The CRF
#' @param cutset A vector of nodes in the cutset
#' @param engine The underlying engine for cutset decoding, possible values are "default", "none", "exact", "chain", and "tree".
#' @param start An initial configuration, a good start will significantly reduce the seraching time
#' @return This function will return the most likely configuration, which is a vector of length \code{crf$n.nodes}.
#'
#' @examples
#'
#' library(CRF)
#' data(Small)
#' d <- decode.cutset(Small$crf, c(2))
#'
#' @export
decode.cutset <- function(crf, cutset, engine = "default", start = apply(crf$node.pot, 1, which.max))
{
engine.id <- c("default"=-1, "none"=0, "exact"=1, "chain"=2, "tree"=3);
clamped <- rep(0, crf$n.nodes)
clamped[cutset] <- 1
newcrf <- clamp.crf(crf, clamped)
.Call(Decode_Cutset, newcrf, engine.id[engine], start)
}
#' Decoding method for low-treewidth graphs
#'
#' Computing the most likely configuration for CRF
#'
#' Exact decoding for low-treewidth graphs using junction trees
#'
#' @param crf The CRF
#' @return This function will return the most likely configuration, which is a vector of length \code{crf$n.nodes}.
#'
#' @examples
#'
#' library(CRF)
#' data(Small)
#' d <- decode.junction(Small$crf)
#'
#' @export
decode.junction <- function(crf)
.Call(Decode_Junction, crf);
#' Decoding method using sampling
#'
#' Computing the most likely configuration for CRF
#'
#' Approximate decoding using sampling (takes a sampling method as input)
#'
#' @param crf The CRF
#' @param sample.method The sampling method
#' @param ... The parameters for \code{sample.method}
#' @return This function will return the most likely configuration, which is a vector of length \code{crf$n.nodes}.
#'
#' @examples
#'
#' library(CRF)
#' data(Small)
#' d <- decode.sample(Small$crf, sample.exact, 10000)
#'
#' @export
decode.sample <- function(crf, sample.method, ...)
.Call(Decode_Sample, crf, sample.method(crf, ...))
#' Decoding method using inference
#'
#' Computing the most likely configuration for CRF
#'
#' Approximate decoding using inference (takes an inference method as input)
#'
#' @param crf The CRF
#' @param infer.method The inference method
#' @param ... The parameters for \code{infer.method}
#' @return This function will return the most likely configuration, which is a vector of length \code{crf$n.nodes}.
#'
#' @examples
#'
#' library(CRF)
#' data(Small)
#' d <- decode.marginal(Small$crf, infer.exact)
#'
#' @export
decode.marginal <- function(crf, infer.method, ...)
apply(infer.method(crf, ...)$node.bel, 1, which.max)
#' Decoding method using loopy belief propagation
#'
#' Computing the most likely configuration for CRF
#'
#' Approximate decoding using max-product loopy belief propagation
#'
#' @param crf The CRF
#' @param max.iter The maximum allowed iterations of termination criteria
#' @param cutoff The convergence cutoff of termination criteria
#' @param verbose Non-negative integer to control the tracing informtion in algorithm
#' @return This function will return the most likely configuration, which is a vector of length \code{crf$n.nodes}.
#'
#' @examples
#'
#' library(CRF)
#' data(Small)
#' d <- decode.lbp(Small$crf)
#'
#' @export
decode.lbp <- function(crf, max.iter = 10000, cutoff = 1e-4, verbose = 0)
.Call(Decode_LBP, crf, max.iter, cutoff, verbose)
#' Decoding method using residual belief propagation
#'
#' Computing the most likely configuration for CRF
#'
#' Approximate decoding using max-product residual belief propagation
#'
#' @param crf The CRF
#' @param max.iter The maximum allowed iterations of termination criteria
#' @param cutoff The convergence cutoff of termination criteria
#' @param verbose Non-negative integer to control the tracing informtion in algorithm
#' @return This function will return the most likely configuration, which is a vector of length \code{crf$n.nodes}.
#'
#' @examples
#'
#' library(CRF)
#' data(Small)
#' d <- decode.rbp(Small$crf)
#'
#' @export
decode.rbp <- function(crf, max.iter = 10000, cutoff = 1e-4, verbose = 0)
.Call(Decode_RBP, crf, max.iter, cutoff, verbose)
#' Decoding method using tree-reweighted belief propagation
#'
#' Computing the most likely configuration for CRF
#'
#' Approximate decoding using max-product tree-reweighted belief propagtion
#'
#' @param crf The CRF
#' @param max.iter The maximum allowed iterations of termination criteria
#' @param cutoff The convergence cutoff of termination criteria
#' @param verbose Non-negative integer to control the tracing informtion in algorithm
#' @return This function will return the most likely configuration, which is a vector of length \code{crf$n.nodes}.
#'
#' @examples
#'
#' library(CRF)
#' data(Small)
#' d <- decode.trbp(Small$crf)
#'
#' @export
decode.trbp <- function(crf, max.iter = 10000, cutoff = 1e-4, verbose = 0)
.Call(Decode_TRBP, crf, max.iter, cutoff, verbose)
#' Decoding method using greedy algorithm
#'
#' Computing the most likely configuration for CRF
#'
#' Approximate decoding with greedy algorithm
#'
#' @param crf The CRF
#' @param restart Non-negative integer to control how many restart iterations are repeated
#' @param start An initial configuration, a good start will significantly reduce the seraching time
#' @return This function will return the most likely configuration, which is a vector of length \code{crf$n.nodes}.
#'
#' @examples
#'
#' library(CRF)
#' data(Small)
#' d <- decode.greedy(Small$crf)
#'
#' @export
decode.greedy <- function(crf, restart = 0, start = apply(crf$node.pot, 1, which.max))
.Call(Decode_Greedy, crf, restart, start)
#' Decoding method using iterated conditional modes algorithm
#'
#' Computing the most likely configuration for CRF
#'
#' Approximate decoding with the iterated conditional modes algorithm
#'
#' @param crf The CRF
#' @param restart Non-negative integer to control how many restart iterations are repeated
#' @param start An initial configuration, a good start will significantly reduce the seraching time
#' @return This function will return the most likely configuration, which is a vector of length \code{crf$n.nodes}.
#'
#' @examples
#'
#' library(CRF)
#' data(Small)
#' d <- decode.icm(Small$crf)
#'
#' @export
decode.icm <- function(crf, restart = 0, start = apply(crf$node.pot, 1, which.max))
.Call(Decode_ICM, crf, restart, start)
#' Decoding method using block iterated conditional modes algorithm
#'
#' Computing the most likely configuration for CRF
#'
#' Approximate decoding with the block iterated conditional modes algorithm
#'
#' @param crf The CRF
#' @param blocks A list of vectors, each vector containing the nodes in a block
#' @param decode.method The decoding method to solve the clamped CRF
#' @param restart Non-negative integer to control how many restart iterations are repeated
#' @param start An initial configuration, a good start will significantly reduce the seraching time
#' @param ... The parameters for \code{decode.method}
#' @return This function will return the most likely configuration, which is a vector of length \code{crf$n.nodes}.
#'
#' @examples
#'
#' library(CRF)
#' data(Small)
#' d <- decode.block(Small$crf, list(c(1,3), c(2,4)))
#'
#' @export
decode.block <- function(crf, blocks, decode.method = decode.tree, restart = 0, start = apply(crf$node.pot, 1, which.max), ...)
{
y <- integer(crf$n.nodes)
y[] <- start
newcrf <- list()
for (i in 1:length(blocks))
{
blocks[[i]] <- sort(blocks[[i]])
clamped <- y
clamped[blocks[[i]]] <- 0
newcrf[[i]] <- clamp.crf(crf, clamped)
}
maxPot <- -1
decode <- y
restart <- max(0, restart)
for (iter in 0:restart)
{
done = F
while(!done)
{
done = T
for (i in 1:length(blocks))
{
clamped <- y
clamped[blocks[[i]]] <- 0
newcrf[[i]] <- clamp.reset(newcrf[[i]], clamped)
temp <- decode.method(newcrf[[i]], ...)
if (any(temp != y[blocks[[i]]]))
{
y[blocks[[i]]] <- temp
done = F
}
}
}
pot <- get.potential(crf, y)
if (pot > maxPot)
{
maxPot <- pot
decode <- y
}
if (iter < restart)
{
y <- ceiling(stats::runif(crf$n.nodes) * crf$n.states)
}
}
decode
}
#' Decoding method using integer linear programming
#'
#' Computing the most likely configuration for CRF
#'
#' Exact decoding with an integer linear programming formulation and approximate using LP relaxation
#'
#' @param crf The CRF
#' @param lp.rounding Boolean variable to indicate whether LP rounding is need.
#' @return This function will return the most likely configuration, which is a vector of length \code{crf$n.nodes}.
#'
#' @examples
#'
#' \dontrun{
#' library(CRF)
#' data(Small)
#' d <- decode.ilp(Small$crf)
#' }
#'
#' @export
decode.ilp <- function(crf, lp.rounding = FALSE)
{
if (!requireNamespace("Rglpk", quietly = TRUE)) {
stop("Package \"Rglpk\" needed for the function decode.ilp to work. Please install it.",
call. = FALSE)
}
vmap.nodes <- matrix(nrow=crf$n.nodes, ncol=2)
vmap.edges <- matrix(nrow=crf$n.edges, ncol=2)
n <- 0
for (i in 1:crf$n.nodes)
{
vmap.nodes[i, 1] <- n + 1
n <- n + crf$n.states[i]
vmap.nodes[i, 2] <- n
}
vnum.nodes <- n
for (i in 1:crf$n.edges)
{
vmap.edges[i, 1] <- n + 1
n <- n + crf$n.states[crf$edges[i,1]] * crf$n.states[crf$edges[i,2]]
vmap.edges[i, 2] <- n
}
vnum.edges <- n - vnum.nodes
vnum.total <- n
obj <- rep(0, vnum.total)
for (i in 1:crf$n.nodes)
{
obj[vmap.nodes[i,1]:vmap.nodes[i,2]] <- -log(crf$node.pot[i,1:crf$n.states[i]])
}
for (i in 1:crf$n.edges)
{
obj[vmap.edges[i,1]:vmap.edges[i,2]] <- -log(crf$edge.pot[[i]])
}
obj[is.infinite(obj)] <- 1000
cnum.nodes <- crf$n.nodes
cnum.edges <- sum(crf$n.states[crf$edges])
cnum.total <- cnum.nodes + cnum.edges
mat <- matrix(0, nrow=cnum.total, ncol=vnum.total)
for (i in 1:crf$n.nodes)
{
mat[i, vmap.nodes[i,1]:vmap.nodes[i,2]] <- 1
}
n <- cnum.nodes
for (i in 1:crf$n.edges)
{
n1 <- crf$edges[i,1]
n2 <- crf$edges[i,2]
for (j in 1:crf$n.states[n1])
{
n <- n + 1
mat[n, vmap.nodes[n1,1]-1+j] <- -1
mat[n, seq.int(vmap.edges[i,1]-1+j, vmap.edges[i,2], by=crf$n.states[n1])] <- 1
}
for (j in 1:crf$n.states[n2])
{
n <- n + 1
mat[n, vmap.nodes[n2,1]-1+j] <- -1
mat[n, (vmap.edges[i,1]+(j-1)*crf$n.states[n1]):(vmap.edges[i,1]-1+j*crf$n.states[n1])] <- 1
}
}
dir <- rep("==", cnum.total)
rhs <- rep(0, cnum.total)
rhs[1:cnum.nodes] <- 1
if (lp.rounding)
{
types <- rep("C", vnum.total)
bounds <- list(upper = list(ind = 1:vnum.total, val = rep(1, vnum.total)))
}
else
{
types <- rep("B", vnum.total)
bounds <- NULL
}
result <- Rglpk::Rglpk_solve_LP(obj, mat, dir, rhs, types = types, bounds = bounds)
if (result$status != 0)
{
warning("LP solution is not optimal.")
}
node.bel <- matrix(0, nrow=crf$n.nodes, ncol=crf$max.state)
for (i in 1:crf$n.nodes)
{
node.bel[i, 1:crf$n.states[i]] <- result$solution[vmap.nodes[i,1]:vmap.nodes[i,2]]
}
apply(node.bel, 1, which.max)
}
Any scripts or data that you put into this service are public.
Add the following code to your website.
For more information on customizing the embed code, read Embedding Snippets.