Nothing
## Relation ensembls, cf. the cluster ensembles in CLUE.
## Note that ensembles are not implemented as containers.
## Properties are stored as a list of .Meta attributes.
## <NOTE>
## It might be nice to encapsulate this a bit more by providing a
## high-level .Meta() accessor. For containers, .get_properties() does
## this; we could have a .Meta() generic with corresponding methods, or
## make relation_properties() generic.
## </NOTE>
##
## <NOTE>
## It is possible to conveniently iterate through containers via
## lapply() [CLUE style] provided there is an as.list() method for the
## container class. E.g.,
## as.list.FOO <- function(x, ...) x$ZZZ
## FOO <- function(...)
## structure(list(ZZZ = list(...)), class = "FOO")
## lapply(FOO(1, 2), function(x) x)
## gives list(1, 2).
## We could thus implement ensembles as containers rather than list
## "structures". But there is little benefit (if at all) in this as
## long as we only have a trivial "list of relations" representation.
## As all relations in an ensemble must have the same domain, we could
## represent ensembles by a single domain and a list of (sparse or
## dense) incidences (again with unclear benefits apart from space
## savings). If we added alternative representations, realizing
## relation ensembles via containers would be much more attractive.
## </NOTE>
##
## Note also that (unlike CLUE), we do not allow the creation of empty
## relation ensembles, so that we always have the domain information.
## It is possible, however, to obtain empty ensembles by subscripting,
## see below.
### * relation_ensemble
relation_ensemble <-
function(..., list = NULL)
{
relations <- lapply(c(list(...), list), as.relation)
if(!(len <- length(relations)))
stop("Cannot create empty relation ensembles.")
domains <- lapply(relations, .domain)
if(len > 1L) {
## Check whether all domains are the same.
if(!all(sapply(domains, .domain_is_equal, domains[[1L]]))) {
## Only need to test domains[-1L] of course, but it is not
## clear whether doing so really saves time.
stop("All relations must have the same domain.")
}
}
.make_relation_ensemble_from_list_and_meta(relations)
}
.make_relation_ensemble_from_list_and_meta <-
function(x, meta = NULL)
{
if(is.null(meta))
meta <- .make_ensemble_meta_from_element(x[[1L]])
.structure(x, .Meta = meta, class = c("relation_ensemble", "tuple"))
}
.make_ensemble_meta_from_element <-
function(x)
list(arity = .arity(x), domain = .domain(x), size = .size(x))
### * is.relation_ensemble
is.relation_ensemble <-
function(x)
inherits(x, "relation_ensemble")
### * as.relation_ensemble
as.relation_ensemble <-
function(x)
UseMethod("as.relation_ensemble")
as.relation_ensemble.data.frame <-
function(x)
{
nms <- rownames(x)
relations <- lapply(x,
function(u) {
names(u) <- nms
as.relation(u)
})
.make_relation_ensemble_from_list_and_meta(relations)
}
as.relation_ensemble.default <-
function(x)
relation_ensemble(x)
as.relation_ensemble.relation_ensemble <- identity
### * Methods
"[.relation_ensemble" <-
function(x, i)
{
## Make subscripting empty ensembles a noop.
if(!length(x)) return(x)
## What should we do when subscripting out of bounds?
## For lists, this gives NULL elements. We could convert them to
## null relations (all incidences zero). For now, we remove them.
y <- NextMethod("[")
.make_relation_ensemble_from_list_and_meta(y[!vapply(y, is.null, NA)],
attr(x, ".Meta"))
}
## <NOTE>
## We could have a [[ method which ensures that the ensemble metadata
## (arity, domain and size) get tucked on. But why should we?
# </NOTE>
`[<-.relation_ensemble` <-
function(x, i, value)
{
value <- as.relation_ensemble(value)
if(!.domain_is_equal(.domain(x), .domain(value)))
stop("All relations must have the same domain.")
y <- NextMethod("[<-")
.make_relation_ensemble_from_list_and_meta(y, attr(x, ".Meta"))
}
`[[<-.relation_ensemble` <-
function(x, i, value)
{
value <- as.relation(value)
if(!.domain_is_equal(.domain(x), .domain(value)))
stop("All relations must have the same domain.")
y <- NextMethod("[[<-")
.make_relation_ensemble_from_list_and_meta(y, attr(x, ".Meta"))
}
`$<-.relation_ensemble` <-
function(x, i, value)
{
value <- as.relation(value)
if(!.domain_is_equal(.domain(x), .domain(value)))
stop("All relations must have the same domain.")
## This does not work:
## y <- NextMethod("$<-")
y <- unclass(x)
y[[i]] <- value
.make_relation_ensemble_from_list_and_meta(y, attr(x, ".Meta"))
}
Ops.relation_ensemble <-
function(e1, e2)
{
## Relation ensembles are of the tuple type, so that comparisons etc
## are performed elementwise. It might be useful to recycle ...
if(missing(e2)) {
## Could have unary '+', '-' and '!'.
## Only complement makes sense. Could make the other a no-op.
if(!(as.character(.Generic) %in% "!"))
stop(gettextf("Unary '%s' not defined for \"%s\" objects.",
.Generic, .Class),
domain = NA)
## Could also do relation_ensemble(list = NextMethod()).
return(.make_relation_ensemble_from_list_and_meta(lapply(e1,
.Generic),
attr(e1,
".Meta")))
}
## Otherwise, keep things simple. Dispatch to tuple method:
out <- NextMethod()
## And massage the return type:
if(as.character(.Generic) %in% c("<", "<=", ">", ">=", "==", "!="))
as.logical(out)
else
relation_ensemble(list = out)
## (Could make the last more efficient, of course.)
}
Summary.relation_ensemble <-
function(..., na.rm = FALSE)
{
ok <- switch(.Generic, max = , min = , range = TRUE, FALSE)
if(!ok)
stop(gettextf("Generic '%s' not defined for \"%s\" objects.",
.Generic, .Class),
domain = NA)
args <- list(...)
## Combine the given relation ensembles.
x <- do.call(c, args)
switch(.Generic,
"min" = .relation_meet(x),
"max" = .relation_join(x),
"range" = {
relation_ensemble(min = .relation_meet(x),
max = .relation_join(x))
})
}
mean.relation_ensemble <-
function(x, ...)
{
relation(domain = relation_domain(x),
incidence = .weighted_sum_of_arrays(lapply(x,
relation_incidence), 1 / length(x)))
}
all.equal.relation_ensemble <-
function(target, current, check.attributes = TRUE, ...)
{
## For now, try avoiding set comparisons via all.equal (for the
## domain information stored in the .Meta attributes).
attr(target, ".Meta") <- NULL
attr(current, ".Meta") <- NULL
NextMethod("all.equal")
## For now, could also directly call
## all.equal.list(target, current,
## check.attributes = check.attributs, ...)
}
as.list.relation_ensemble <-
function(x, ...)
{
## We used to have
## attributes(x) <- NULL
## x
## but why should we drop names?
x <- unclass(x)
attr(x, ".Meta") <- NULL
x
}
c.relation_ensemble <-
function(..., recursive = FALSE)
{
relations <- unlist(lapply(list(...), as.relation_ensemble),
recursive = FALSE)
relation_ensemble(list = relations)
}
print.relation_ensemble <-
function(x, ...)
{
len <- length(x)
if(len)
writeLines(sprintf(ngettext(len,
"An ensemble of %d relation of size %s.",
"An ensemble of %d relations of size %s."),
len,
paste(.size(x), collapse = " x ")))
else
writeLines(gettext("An empty relation ensemble."))
invisible(x)
}
rep.relation_ensemble <-
function(x, times, ...)
.make_relation_ensemble_from_list_and_meta(NextMethod("rep"),
attr(x, ".Meta"))
rev.relation_ensemble <-
t.relation_ensemble <-
function(x)
.make_relation_ensemble_from_list_and_meta(lapply(x, t),
attr(x, ".Meta"))
unique.relation_ensemble <-
function(x, incomparables = FALSE, ...)
.make_relation_ensemble_from_list_and_meta(NextMethod("unique"),
attr(x, ".Meta"))
### * Utilities
### ** Meet and Join.
## <NOTE>
## One might think that one should more generally order relations by
## using the fuzzy intersection and union for the meet and join,
## respectively. However, to obtain an order this requires (see e.g.
## http://en.wikipedia.org/wiki/Lattice_(order)) that the absorption
## laws are satisfied, implying
## S(x, T(x, y)) = x
## T(x, S(x, y)) = x
## for all x and y. Using that T <= min and S >= max one can show
## (e.g., Fodor and Roubens, Section 1.5.2) that the above implies T =
## min and S = max, i.e., the standard Zadeh logic, corresponding to the
## natural point-wise order of the indicences.
## </NOTE>
.relation_meet <-
function(x)
{
if(!is.relation_ensemble(x))
stop("Argument 'x' must be a relation ensemble.")
I <- do.call(pmin, lapply(x, relation_incidence))
.make_relation_from_domain_and_incidence(.domain(x), I)
}
.relation_join <-
function(x)
{
if(!is.relation_ensemble(x))
stop("Argument 'x' must be a relation ensemble.")
I <- do.call(pmax, lapply(x, relation_incidence))
.make_relation_from_domain_and_incidence(.domain(x), I)
}
### ** .canonicalize_relation_ensemble
## <NOTE>
## This should no longer be needed now that creating relations always
## canonicalizes to the unique set order.
## .canonicalize_relation_ensemble <-
## function(x, D)
## {
## ## Canonicalize a relation ensemble to have its domain elements use
## ## the same *internal* order as the elements of D (assuming that the
## ## domain of the ensemble is known to equal D in the sense that the
## ## respective elements are the same sets).
## ##
## ## Note that relation ensembles are always canonicalized.
## if(!length(x)) return(x)
## pos <- .match_domain_components(lapply(D, as.list),
## lapply(.domain(x), as.list))
## if(!any(sapply(pos, is.unsorted))) return(x)
## x <- lapply(x, .canonicalize_relation, D, pos)
## size <- lapply(D, length)
## meta <- list(arity = length(size), domain = D, size = size)
## .make_relation_ensemble_from_list_and_meta(x, meta)
## }
## </NOTE>
### ** .is_ensemble_of_endorelations
.is_ensemble_of_endorelations <-
function(x)
{
## Check whether we have an ensemble of endorelations (assuming that
## ensembles are known to have identical identical domains).
if(length(x))
relation_is_endorelation(x[[1L]])
else
length(unique(.domain(x))) == 1L
}
### ** .is_ensemble_of_crisp_relations
.is_ensemble_of_crisp_relations <-
function(x)
all(vapply(x, relation_is_crisp, NA))
### Local variables: ***
### mode: outline-minor ***
### outline-regexp: "### [*]+" ***
### End: ***
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.