#' Predecessor and Successor Functions
#'
#' Functions for traversing the BTG (Better-Than-Graph or Hasse diagram) of a preference.
#'
#' @name pred_succ
#' @param df (optional) A data frame characterizing the set wherein predecessors/successors are searched.
#' If \code{df} is \code{NULL} then the data frame associated with the preference is used.
#' Causes an error if \code{df == NULL} and no data frame is associated.
#' @param v A numeric vector of indices in \code{df}. This represents the set of tuples for which predecessors/successors are searched.
#' @param p A preference. Worse tuples in the induced order are successors and better tuples are predecessors.
#' @param intersect (optional) Logical value.
#' If it is \code{FALSE} (by default) the union of all predecessors/successors of \code{v} is returned.
#' For \code{intersect = TRUE} the intersection of those values is returned.
#'
#' @details
#'
#' These functions return the predecessors and successors in the Better-Than-Graph of a preference.
#' Note that the successors/predecessors can can be plotted via \code{\link{get_btg}}.
#' Before any of the successor/predecessor functions can be used the initialization has to be called as follows:
#'
#' \code{init_pred_succ(p, df)}
#'
#' There \code{p} is a preference object and \code{df} a data frame.
#' When this done, the data frame \code{df} is associated with \code{p}, i.e.,
#' implicitly \code{\link{assoc.df}} is called.
#' If the preference has already an associated data frame, \code{df} can be omitted. For example
#'
#' \code{p <- low(mpg, df = mtcars)} \cr
#' \code{init_pred_succ(p)}
#'
#' does the initialization of the preference \code{low(mpg)} on the data set \code{mtcars}.
#'
#' The \code{init_pred_succ} function calculates the Better-Than-Relation on \code{df} w.r.t. \code{p}.
#' Afterwards the predecessor and successor functions, as subsequently described, can be called.
#' The value of \code{v} is a numeric vector within \code{1:nrow(df)}
#' and characterizes a subset of tuples in \code{df}.
#' The return value of these functions is again a numeric vector referring to the row numbers in \code{df}
#' and it is always ordered ascending, independently of the order of the indices in \code{v}.
#'
#'
#' \describe{
#' \item{\code{all_pred(p, v)}}{Returns all predecessors of \code{v}, i.e., indices of better tuples than \code{v}.}
#' \item{\code{all_succ(p, v)}}{Returns all successors of \code{v}, i.e., indices of worse tuples than \code{v}.}
#' \item{\code{hasse_pred(p, v)}}{Returns the direct predecessors of \code{v},
#' i.e., indices of better tuples than \code{v} where the better-than-relation is contained in the transitive reduction.}
#' \item{\code{hasse_succ(p, v)}}{Returns the direct successors of \code{v},
#' i.e., indices of worse tuples than \code{v} where the better-than-relation is contained in the transitive reduction.}
#' }
#'
#' If \code{v} has length 1, then the value of \code{intersect} does not matter, as there is nothing to intersect or join.
#' For scalar values \code{x} and \code{y} the following identities hold, where \code{f} is one of the predecessor/successor functions:
#'
#' \code{f(p, c(x, y), intersect = FALSE) == union(f(p, x), f(p, y))}
#'
#' \code{f(p, c(x, y), intersect = TRUE) == intersect(f(p, x), f(p, y))}
#'
#'
#' @examples
#'
#' # Preference on mtcars for high mpg and low weight
#' p <- high(mpg) * low(wt)
#' init_pred_succ(p, mtcars)
#'
#' # Helper to show mpg/hp values
#' show_vals <- function(x) mtcars[x,c('mpg','wt')]
#'
#' # Pick some tuple "in the middle":
#' show_vals(10)
#'
#' # Show (direct) predecessors/successors of tuple 10:
#' show_vals(hasse_pred(p, 10)) # Next better car
#' show_vals(hasse_succ(p, 10)) # Next worse car
#' show_vals(all_pred(p, 10)) # All better cars
#' show_vals(all_succ(p, 10)) # All worse cars
NULL
#' @rdname pred_succ
#' @export
init_pred_succ <- function(p, df = NULL) {
# For compatibility with rPref <= 1.0 where we had init_pred_succ(df, p)
if (is.preference(df) && !is.preference(p)) {
warning('Wrong order of arguments in "init_pred_succ(p, df)". This has changed in rPref >= 1.1')
parent_var <- substitute(df)
p <- init_pred_succ_internal(df, p, substitute(p))
} else {
# For the usual call of this function in rPref >= 1.1
parent_var <- substitute(p)
p <- init_pred_succ_internal(p, df, substitute(df))
}
# Returns nothing but modifies parent preference object
# One of the ugly hacks which were needed since we changed from reference classes to S4
if (!is.symbol(parent_var)) {
stop.syscall("init_pred_succ has to called on a preference stored in a variable.")
}
assign(as.character(parent_var), p, parent.frame())
}
#' @rdname pred_succ
#' @export
hasse_pred <- function(p, v, intersect = FALSE) {
h_predsucc(p, v, do_intersect = intersect, succ = FALSE)
}
#' @rdname pred_succ
#' @export
hasse_succ <- function(p, v, intersect = FALSE) {
h_predsucc(p, v, do_intersect = intersect, succ = TRUE)
}
#' @rdname pred_succ
#' @export
all_pred <- function(p, v, intersect = FALSE) {
all_predsucc(p, v, do_intersect = intersect, succ = FALSE)
}
#' @rdname pred_succ
#' @export
all_succ <- function(p, v, intersect = FALSE) {
all_predsucc(p, v, do_intersect = intersect, succ = TRUE)
}
# Internal implementation
# -----------------------
init_pred_succ_internal <- function(p, df, df_call) {
pref.df.check(p, df)
# Overwrite associated data frame, do partial evaluation
if (!is.null(df)) {
p@df_src <- compose.df(df, df_call)
p <- evaluate(p, get_static_terms(p@df_src$df))
} else if (length(p@df_src) == 0) stop("No data source was specified!")
# Use specified data.frame from now on
res <- get_scores(p, 1, p@df_src$df)
# We need the modified preference object for cmp/eq
p <- res$p
# Cached scorevals
p@scorevals <- res$scores
serialized <- pserialize(p)
# Get Hasse Matrix from C++ function, add 1 for R indices (starting at 1)
p@hasse_mtx <- t(get_hasse_impl(p@scorevals, serialized)) + 1
p@cache_available <- TRUE
# returns modified preference
return(p)
}
# Hasse diagram successors/predecessors
h_predsucc <- function(p, inds, do_intersect, succ) {
pref.df.check(p)
check_cache(p)
# Select indices predecessors/successors
if (succ) {
l_index <- 1
r_index <- 2
} else {
l_index <- 2
r_index <- 1
}
# Selection aggregation method, if inds is a vector (and not a single value)
if (do_intersect) agg <- intersect
else agg <- union
# Do the calculation
if (length(inds) == 0) {
return(numeric(0))
} else if (length(inds) == 1) {
return(p@hasse_mtx[p@hasse_mtx[,l_index] == inds, r_index])
} else {
res_inds <- lapply(inds, function(x) p@hasse_mtx[p@hasse_mtx[,l_index] == x, r_index])
return(sort(Reduce(agg, res_inds[-1], res_inds[[1]])))
}
}
# All succesors/predecessors (sorting not necessary because of "which")
all_predsucc = function(p, inds, do_intersect, succ) {
pref.df.check(p)
check_cache(p)
# does not need hasse diagram, but needs p@scorevals
# Select indices predecessors/successors
if (succ) cmpfun <- function(x, y) cmp(p, x, y, p@scorevals)
else cmpfun <- function(x, y) cmp(p, y, x, p@scorevals)
# Selection aggregation method, if inds is a vector (and not a single value)
if (do_intersect) agg <- pmin # min is logically equivalent to intersection
else agg <- pmax # max is logically equivalent to union
all_inds <- 1:nrow(p@scorevals)
if (length(inds) == 0) {
return(numeric(0))
} else if (length(inds) == 1) {
return(which(cmpfun(inds, all_inds)))
} else {
return(which(as.logical(do.call(agg, lapply(inds, function(x) cmpfun(x, all_inds) )))))
}
}
check_cache <- function(p) {
if (!p@cache_available)
stop.syscall(paste0("In calculation of predecessors/successors : No data set avaible. ",
"Run `init_succ_pref(df)` or `assoc.df(p) <- df` first."))
}
pref.df.check <- function(pref, df = NULL) {
# Note that also data.table fulfills is.data.frame(.) = TRUE
if (!is.actual.preference(pref)) stop.syscall("First argument has to be a preference.")
if (!is.null(df) && !is.data.frame(df)) stop.syscall("Second argument has to be a data.frame or NULL.")
}
Add the following code to your website.
For more information on customizing the embed code, read Embedding Snippets.