# All functions are internal!
# General preference (only for internal use)
preference <- setClass("preference",
slots = c(
# list containing "df" and "info_str", list() means "not set"
# accessed via constructor and assoc.df
df_src = "list",
# this is set in get_scores
score_id = "numeric",
# These are used by init_pred_succ in pred-succ.r
cache_available = "logical",
hasse_mtx = "matrix",
scorevals = "data.frame"
),
prototype = list(
# also used for string output (as.character)
cache_available = FALSE
),
contains = "VIRTUAL"
)
setMethod("show", signature(object = "preference"),
# not explicitly exported - called implicitly
# show.pref(p, df) is exported, see show-pref
function(object) {
cat('[Preference] ', as.character(object), '\n', sep = "")
if (length(object@df_src) > 0)
cat(' * associated data source: ', object@df_src$info_str, '\n', sep = "")
if (object@cache_available)
cat(' * Hasse matrix for predecessors/successors available')
}
)
setGeneric(name = "cmp", def = function(object, i, j, score_df) {standardGeneric("cmp")} )
setGeneric(name = "eq", def = function(object, i, j, score_df) {standardGeneric("eq")} )
setGeneric(name = "pserialize", def = function(object) {standardGeneric("pserialize")} )
setGeneric(name = "evaluate", def = function(object, static_terms) {standardGeneric("evaluate")} )
setGeneric(name = "calc_scores", def = function(object, df, frm) {standardGeneric("calc_scores")} )
setGeneric(name = "get_scores", def = function(object, next_id, df) {standardGeneric("get_scores")} )
is.preference <- function(x) inherits(x, "preference")
# Empty preference
# ----------------
# Special empty preference class. All scores are 0
emptypref <- setClass("emptypref",
slots = character(0),
prototype = list(),
contains = "preference"
)
setMethod("as.character", signature(x = "emptypref"),
function(x, parent_op = "") {
return("(empty)")
}
)
#' @export
setMethod("as.expression", signature(x = "emptypref"),
function(x, ...) {
return(expression(empty()))
}
)
setMethod("get_scores", signature(object = "emptypref"),
function(object, next_id, df) {
return(list(p = object, next_id = next_id + 1, scores = as.data.frame(rep(0, nrow(df)))))
}
)
setMethod("length", signature(x = "emptypref"),
function(x) {
return(0)
}
)
setMethod("cmp", signature(object = "emptypref"),
function(object, i, j, score_df) { # TRUE if i is better than j
return(FALSE)
}
)
setMethod("eq", signature(object = "emptypref"),
function(object, i, j, score_df) { # TRUE if i is equal to j
return(TRUE)
}
)
setMethod("pserialize", signature(object = "emptypref"),
function(object) {
return(list(kind = 's'))
}
)
# Nothing to do for empty preference
setMethod("evaluate", signature(object = "emptypref"),
function(object, static_terms) {
return(object)
}
)
## @importClassesFrom lazyeval lazy
# cmp/eq functions are not needed for C++ BNL algorithms, but for igraph, etc.
# Base preferences
setOldClass("lazy")
basepref <- setClass("basepref",
slots = c(
lazy_expr = "lazy",
op = "character"
),
prototype = list(),
contains = "preference"
)
setMethod("initialize", "basepref",
function(.Object, lazy_expr) {
.Object@lazy_expr <- lazy_expr
return(.Object)
}
)
setMethod("get_scores", signature(object = "basepref"),
function(object, next_id, df) {
object@score_id <- next_id
# Add data.frame to the environment without modifying original environment
frm <- new.env(parent = object@lazy_expr$env)
assign("df__", df, pos = frm)
# Calc score of base preference
# calc_score is defined in low/high/true preferences
scores <- calc_scores(object, df, frm)
# Check if length of score vector is ok
# (length 1 might happen; has to be appropriately extended)
if (length(scores) != nrow(df)) {
if (length(scores) == 1) scores <- rep(scores, nrow(df))
else stop(paste0("Evaluation of base preference ", as.character(object),
" does not have the same length as the data frame!"))
}
# Increase next_id after base preference
return(list(p = object, next_id = next_id + 1, scores = as.data.frame(scores)))
}
)
setMethod("length", signature(x = "basepref"),
function(x) {
return(1)
}
)
setMethod("cmp", signature(object = "basepref"),
function(object, i, j, score_df) { # TRUE if i is better than j
return(score_df[i, object@score_id] < score_df[j, object@score_id])
}
)
setMethod("eq", signature(object = "basepref"),
function(object, i, j, score_df) { # TRUE if i is equal to j
return(score_df[i, object@score_id] == score_df[j, object@score_id])
}
)
setMethod("as.character", signature(x = "basepref"),
function(x, parent_op = "") {
return(paste0(x@op, '(', as.character(as.expression(x@lazy_expr$expr)), ')'))
}
)
setMethod("pserialize", signature(object = "basepref"),
function(object) {
return(list(kind = 's'))
}
)
setMethod("evaluate", signature(object = "basepref"),
function(object, static_terms) {
# get_inner_expr is not generic, only used for baseprefs!
object@lazy_expr$expr <- get_inner_expr(object, static_terms)
return(object)
}
)
#' @export
setMethod("as.expression", signature(x = "basepref"),
function(x, ...) {
# x is a base preference object, where the constructor name is given by x@op
args <- list(...)
# get_expr_evaled returns a Call
if (!is.null(args[['static_terms']])) {
expr <- get_inner_expr(x, args[['static_terms']])
} else {
expr <- x@lazy_expr$expr
}
# this has to return an expression!
return(as.expression(call(x@op, expr)))
}
)
lowpref <- setClass("lowpref",
prototype = list(op = "low"),
contains = "basepref"
)
setMethod("calc_scores", signature(object = "lowpref"),
function(object, df, frm) {
# frm is from lazy_eval object, augmented by df__, do not use lazy_eval
res <- eval(object@lazy_expr$expr, df, frm)
if (!is.numeric(res)) stop("For the low preference ", as.character(object), " the expression must be numeric!")
return(res)
}
)
is.lowpref <- function(x) inherits(x, "lowpref")
highpref <- setClass("highpref",
prototype = list(op = "high"),
contains = "basepref"
)
setMethod("calc_scores", signature(object = "highpref"),
function(object, df, frm) {
res <- eval(object@lazy_expr$expr, df, frm)
if (!is.numeric(res)) stop("For the high preference ", as.character(object), " the expression must be numeric!")
return(-res)
}
)
is.highpref <- function(x) inherits(x, "highpref")
truepref <- setClass("truepref",
prototype = list(op = "true"),
contains = "basepref"
)
setMethod("initialize", "truepref",
function(.Object, ...) {
.Object <- methods::callNextMethod(.Object, ...)
if (isTRUE(getOption("rPref.checkLogicalAndOr", default = TRUE))) {
chr_expr <- as.character(as.expression(.Object@lazy_expr$expr))
if (length(chr_expr > 0) && grepl(" \\|\\||\\&\\& ", chr_expr))
warning(paste0("In true(...) :\n",
"Detected logical operator '&&' or '||' in logical expreesion -- possibly unexpected behavior.\n",
"Probably you intended '&' or '|'?\n",
"Set \n'options(rPref.checkLogicalAndOr = FALSE)' \nto disable this warning."),
call. = FALSE)
}
return(.Object)
}
)
setMethod("calc_scores", signature(object = "truepref"),
function(object, df, frm) {
res <- eval(object@lazy_expr$expr, df, frm)
if (!is.logical(res)) stop("For the true preference ", as.character(object), " the expression must be logical!")
return(1 - as.numeric(res))
}
)
is.truepref <- function(x) inherits(x, "truepref")
# Complex preferences
# -------------------
# they get df_src as argument (propagated from baseprefs or sub-preferences)
# Unary complex preference: Reverse preference (reevrsing the order)
reversepref <- setClass("reversepref",
prototype = list(),
slots = c(
p = "preference"
),
contains = "preference"
)
setMethod("initialize", "reversepref",
function(.Object, p) {
.Object@p <- p
return(.Object)
}
)
setMethod("get_scores", signature(object = "reversepref"),
function(object, next_id, df) {
res <- get_scores(object@p, next_id, df)
object@p <- res$p
return(list(p = object, next_id = res$next_id, scores = res$scores))
}
)
setMethod("as.character", signature(x = "reversepref"),
function(x, parent_op = "") {
return(paste0('-', as.character(x@p, parent_op = parent_op)))
}
)
setMethod("cmp", signature(object = "reversepref"),
function(object, i, j, score_df) { # TRUE if i is better than j
return(cmp(object@p, j, i, score_df)) # swap i/j for realising reverse
}
)
setMethod("eq", signature(object = "reversepref"),
function(object, i, j, score_df) { # TRUE if i is equal to j
eq(object@p, i, j, score_df)
}
)
setMethod("pserialize", signature(object = "reversepref"),
function(object) {
return(list(kind = '-', p = pserialize(object@p)))
}
)
setMethod("length", signature(x = "reversepref"),
function(x) {
return(length(x@p))
}
)
setMethod("evaluate", signature(object = "reversepref"),
function(object, static_terms) {
object@p <- evaluate(object@p, static_terms)
return(object)
}
)
is.reversepref <- function(x) inherits(x, "reversepref")
#' @export
setMethod("as.expression", signature(x = "reversepref"),
function(x, ...) {
return(as.expression(call('-', as.expression(x@p, ...)[[1]])))
}
)
# Binary complex preferences
complexpref <- setClass("complexpref",
prototype = list(),
slots = c(
p1 = "preference",
p2 = "preference",
op = "character"
),
contains = "preference"
)
setMethod("initialize", "complexpref",
function(.Object, p1, p2) {
.Object@p1 <- p1
.Object@p2 <- p2
return(.Object)
}
)
setMethod("get_scores", signature(object = "complexpref"),
function(object, next_id, df) {
# ** Usual complex preference
res1 <- get_scores(object@p1, next_id, df)
res2 <- get_scores(object@p2, res1$next_id, df)
object@p1 <- res1$p
object@p2 <- res2$p
return(list(p = object, next_id = res2$next_id, scores = cbind(res1$scores, res2$scores)))
}
)
setMethod("as.character", signature(x = "complexpref"),
function(x, parent_op = "") {
res <- paste0(as.character(x@p1, parent_op = x@op), ' ', x@op, ' ', as.character(x@p2, parent_op = x@op))
if (parent_op != "" && x@op != parent_op) res <- embrace(res)
return(res)
}
)
setMethod("pserialize", signature(object = "complexpref"),
function(object) {
return(list(kind = object@op, p1 = pserialize(object@p1), p2 = pserialize(object@p2)))
}
)
setMethod("length", signature(x = "complexpref"),
function(x) {
return(length(x@p1) + length(x@p2))
}
)
# Equivalence composition for ALL complex preferences
setMethod("eq", signature(object = "complexpref"),
function(object, i, j, score_df) { # TRUE if i is equal to j
return(eq(object@p1, i, j, score_df) & eq(object@p2, i, j, score_df))
}
)
setMethod("evaluate", signature(object = "complexpref"),
function(object, static_terms) {
object@p1 <- evaluate(object@p1, static_terms)
object@p2 <- evaluate(object@p2, static_terms)
return(object)
}
)
is.binarycomplexpref <- function(x) inherits(x, "complexpref")
#' @export
setMethod("as.expression", signature(x = "complexpref"),
function(x, ...) {
# x is a base preference OR complex preference
return(as.expression(call(x@op, as.expression(x@p1, ...)[[1]], as.expression(x@p2, ...)[[1]])))
}
)
paretopref <- setClass("paretopref",
prototype = list(op = "*"),
contains = "complexpref"
)
setMethod("cmp", signature(object = "paretopref"),
function(object, i, j, score_df) { # TRUE if i is better than j
return ( (cmp(object@p1, i, j, score_df) | eq(object@p1, i, j, score_df)) & cmp(object@p2, i, j, score_df) |
(cmp(object@p2, i, j, score_df) | eq(object@p2, i, j, score_df)) & cmp(object@p1, i, j, score_df) )
}
)
unionpref <- setClass("unionpref",
prototype = list(op = "+"),
contains = "complexpref"
)
setMethod("cmp", signature(object = "unionpref"),
function(object, i, j, score_df) { # TRUE if i is better than j
return (cmp(object@p1, i, j, score_df) | cmp(object@p2, i, j, score_df))
}
)
intersectionpref <- setClass("intersectionpref",
prototype = list(op = "|"),
contains = "complexpref"
)
setMethod("cmp", signature(object = "intersectionpref"),
function(object, i, j, score_df) { # TRUE if i is better than j
return (cmp(object@p1, i, j, score_df) & cmp(object@p2, i, j, score_df))
}
)
# Prioritization preferences
# --------------------------
# double has 52 bits significand, thus the largest double number d which surely fulfills "d \neq d+1" is 2^52
MAX_CHAIN_LENGTH <- 52
priorpref <- setClass("priorpref",
slots = c(
chain_size = "numeric",
prior_chain = "logical",
prior_score_id = "numeric"
),
prototype = list(op = "&",
chain_size = numeric(0),
prior_chain = FALSE,
prior_score_id = numeric(0)),
contains = "complexpref"
)
# not generic, prior-specific. calculate recursively the length of a prior chain
# returning NULL means, that the given preference is not a prior chain
get_prior_length <- function(object) {
# Calculate sum
len <- 0
for (p in c('p1', 'p2')) {
if (is.priorpref(methods::slot(object, p))) {
res <- get_prior_length(methods::slot(object, p))
if (is.null(res)) return(NULL)
methods::slot(object, p) <- res$p
len <- len + res$len
} else if (is.truepref(methods::slot(object, p))) {
len <- len + 1
} else {
return(NULL)
}
# Store chain_size for get_scores(..., get_subtree = TRUE)
object@chain_size <- len
}
# has to return p as this was modified
return(list(p = object, len = len))
}
# Calculate prior-chain score, not generic, prior-specific
# does not modify the object, hence does not return it!
get_priorchain_scores <- function(object, next_id, prior_length, df) {
scores <- 0
for (p in c('p1', 'p2')) {
if (is.priorpref(methods::slot(object, p))) {
res <- get_priorchain_scores(methods::slot(object, p), next_id, prior_length, df)
scores <- scores + res$scores
next_id <- res$next_id
} else if (is.truepref(methods::slot(object, p))) { # p is not prioritization, use generic!
res <- get_scores(methods::slot(object, p), 1, df)
scores <- scores + 2 ^ (prior_length - next_id) * res$scores
# Increase next_id after true preference
next_id <- next_id + 1
}
}
return(list(next_id = next_id, scores = scores))
}
setMethod("get_scores", signature(object = "priorpref"),
function(object, next_id, df) {
# call specific function for prior-pref
return(get_scores_prior(object, next_id, df))
}
)
# Get scorevals, specially consider prior-chains. Called *before* serialize! Not generic, prior-specific
get_scores_prior <- function(object, next_id, df, get_subtree = FALSE) {
# By default false
object@prior_chain = FALSE
if (get_subtree) { # It's a prior-chain, but perhaps to large
if (object@chain_size <= MAX_CHAIN_LENGTH) { # subtree which is sufficiently small
# Set prior-chain (pseudo score preference)
object@prior_chain = TRUE
object@prior_score_id = next_id
res <- get_priorchain_scores(object, 1, object@chain_size, df) # does not return pref!
return(list(p = object, next_id = next_id + 1, scores = res$scores))
} # -> else: see block "** All else-paths"
} else {
# ** Prior chains
res_prior <- get_prior_length(object)
# Check if len > 1 (a real chain)
if (!is.null(res_prior) && (res_prior$len > 1)) {
prior_len <- res_prior$len
object@chain_size <- res_prior$p@chain_size
# check if maxval is suffcient small to get distinctive score vals (double precision!)
if (prior_len <= MAX_CHAIN_LENGTH) {
# Set prior-chain (pseudo score preference)
object@prior_chain = TRUE
object@prior_score_id = next_id
res <- get_priorchain_scores(object, 1, prior_len, df) # does not return pref!
return(list(p = object, next_id = next_id + 1, scores = res$scores))
} else {
# Limit reached - stop the recursive search for chains
# Give a warning for all unbalanced trees
if (is.priorpref(object@p1) && object@p1$chain_size > MAX_CHAIN_LENGTH && is.truepref(object@p2) ||
is.priorpref(object@p2) && object@p2$chain_size > MAX_CHAIN_LENGTH && is.truepref(object@p1))
warning(paste0("Prioritization chain of true-preferences exceeded maximal size (", MAX_CHAIN_LENGTH, ") ",
"and the operator tree is unbalanced. ",
"This is a performance issue. It is recommended to build chains like ",
"(P1 & ... & P", MAX_CHAIN_LENGTH, ") & ... & (P1 & ... & P", MAX_CHAIN_LENGTH, ") ",
"for better performance of the preference evaluation."))
# Change to search with known chain_sizes and use flag get_subtree = TRUE
res <- get_scores_prior(object, next_id, df, get_subtree = TRUE)
return(list(p = res$object, next_id = res$next_id, scores = res$scores))
}
}
}
# ** All else-paths: Handle like usual complex preference, but propagate get_subtree
res1 <- if (is.priorpref(object@p1)) get_scores_prior(object@p1, next_id, df, get_subtree) else get_scores(object@p1, next_id, df)
res2 <- if (is.priorpref(object@p2)) get_scores_prior(object@p2, res1$next_id, df, get_subtree) else get_scores(object@p2, res1$next_id, df)
object@p1 <- res1$p
object@p2 <- res2$p
return(list(p = object, next_id = res2$next_id, scores = cbind(res1$scores, res2$scores)))
}
setMethod("pserialize", signature(object = "priorpref"),
function(object) {
if (object@prior_chain) # Prior chain is like a numerical base preference
return(list(kind = 's'))
else
return(methods::callNextMethod(object))
}
)
setMethod("cmp", signature(object = "priorpref"),
function(object, i, j, score_df) { # TRUE if i is better than j
if (object@prior_chain) # Prior-Chain => Score Pref
return(score_df[i, object@prior_score_id] < score_df[j, object@prior_score_id])
else # Usual composition function for prior-preference
return( cmp(object@p1, i, j, score_df) |
(eq( object@p1, i, j, score_df) & cmp(object@p2, i, j, score_df)) )
}
)
setMethod("eq", signature(object = "priorpref"),
function(object, i, j, score_df) { # TRUE if i is equal to j
if (object@prior_chain) # Prior-Chain => Score Pref
return(score_df[i, object@prior_score_id] == score_df[j, object@prior_score_id])
else
return(methods::callNextMethod(object, i, j, score_df))
}
)
is.priorpref <- function(x) inherits(x, "priorpref")
# Non-abstract preference?
is.actual.preference <- function(x) (is.base_pref(x) || is.complex_pref(x) || is.empty_pref(x))
# Helper functions
# ----------------
# Expression (as a CALL!) of preference with partial evaluation
# only called by as.expression.basepref, NOT generic
get_inner_expr <- function(object, static_terms = NULL) {
if (is.null(static_terms)) return(object@lazy_expr$expr)
get_expr_evaled = function(lexpr) {
# Helper for transforming an evaluated object into expression
get_expr <- function(val) {
if (is.preference(val)) {
# propagete preference -> expression
# (even it is unlikely that a base-pref expression contains a preference)
return(as.expression(val, static_terms = static_terms))
} else if (length(val) <= 1) {
# atomic objects
return(as.expression(val))
} else {
# non-atomic objects, we assume lists or vectors
if (is.list(val)) op <- quote(list)
else if (is.vector(val)) op <- quote(c)
else stop(paste0("Cannot evaluate the object ", as.character(val)))
return(as.expression(as.call(c(list(op), as.list(val)))))
}
}
lexpr <- lexpr[[1]] # unwrap expression
if (is.symbol(lexpr)) {
lexpr_chr <- as.character(lexpr)
if (lexpr_chr == '...') # ... cannot be eval'd directly!
return(list(expr = lexpr, final = FALSE)) # ... is never final, will be evaluated above if possible
else if (any(vapply(static_terms, function(x) identical(lexpr, x), TRUE)))
return(list(expr = lexpr, final = TRUE)) # x is a static_term => final
else if (lexpr_chr == 'df__')
return(list(expr = lexpr, final = TRUE)) # special variable df__ => final
else # eval a symbol (e.g. a number)
return(list(expr = get_expr(eval(lexpr, object@lazy_expr$env)), final = FALSE))
} else if (length(lexpr) == 1) { # Not a symbol => not final
return(list(expr = lexpr, final = FALSE))
} else if (length(lexpr[1]) == 1 && as.character(lexpr[1]) == '$') { # object$attribute operator
# first evaluate the object
expr_eval_first <- get_expr_evaled(lexpr[2])
if (expr_eval_first$final == FALSE) # not final => re-eval object$attribute
return(list(expr = get_expr(eval(lexpr, object@lazy_expr$env)), final = FALSE))
else # final => return the object_new$attribute
return(list(expr = call('$', expr_eval_first$expr, lexpr[3][[1]]), final = TRUE))
} else { # n-ary function/operator
# Go into recursion and generate new term
lexpr_lst <- as.list(lexpr) # New expression as list
lexpr_names <- if (is.null(names(lexpr_lst))) rep("", length(lexpr)) else names(lexpr_lst) # Preserve names
# Collect operands and names
lexpr_lst <- lexpr_lst[1]
names(lexpr_lst) <- ""
expr_evals <- list()
for (i in 2:length(lexpr)) {
# catch empty symbol as occuring in, e.g., df[,1].
if (is.symbol(lexpr[i][[1]]) && as.character(lexpr[i][[1]]) == '') {
# Must not be stored in a variable, hence calling get_expr_evaled CANNOT work!
# -> save to evaled, not final
lexpr_lst <- c(lexpr_lst, lexpr[i][[1]])
expr_evals[[i-1]] <- list(final = FALSE) # add final = FALSE manually to emulate usual structure
} else { # All other (non-empty!) sub-expression
# ** Recursion call!
expr_evals[[i-1]] <- get_expr_evaled(lexpr[i])
# Catch abstract function argument "..."
if (identical(expr_evals[[i-1]]$expr, quote(...))) {
lexpr_lst <- c(lexpr_lst, eval(expression(list(...)), object@lazy_expr$env)) # Re-Evaulation!
} else {
# Usual recursive call result
lexpr_lst <- c(lexpr_lst, as.expression(expr_evals[[i-1]]$expr)[[1]]) # Put terms together
names(lexpr_lst)[length(lexpr_lst)] <- lexpr_names[i]
}
}
}
lexpr_new <- as.call(lexpr_lst)
# Check if not final
if (all(vapply(expr_evals, function(x) x$final, TRUE) == FALSE)) {
# ** re-eval
# Especially eval ... at that level where ... is an operand
# Evaluate the entire term if possible (no final symbol occurs!)
return(list(expr = get_expr(eval(lexpr, object@lazy_expr$env)), final = FALSE)) # not final
} else {
return(list(expr = lexpr_new, final = TRUE)) # already final!
}
}
} # End get_expr_evaled
# Call get_expr_evaled with my own expression and extract result
return(get_expr_evaled(as.expression(object@lazy_expr$expr))$expr)
}
# Remove brackets from string if existing
unbrace <- function(x) {
if (substr(x, 1, 1) == "(" && substr(x, nchar(x), nchar(x)) == ")") return(substr(x, 2, nchar(x)-1))
else return(x)
}
# Add brackets to string
embrace <- function(x) {
return(paste0('(', x, ')'))
}
Add the following code to your website.
For more information on customizing the embed code, read Embedding Snippets.