# R/sugeno.R In lfl: Linguistic Fuzzy Logic

#### Documented in sugeno

#' A factory function for creation of sugeno-integrals.
#'
#' @param measure A non-decreasing function that assigns a truth value from the
#'   \eqn{[0, 1]} interval to the either relative or absolute quantity
#' @param relative Whether the measure assumes relative or absolute quantity.
#'   Relative quantity is always a number from the \eqn{[0,1]} interval
#' @param strong Whether to use the strong conjunction (TRUE) or the weak
#'   conjunction (FALSE)
#' @param alg The underlying algebra must be either a string (one from 'lukasiewicz',
#'   'goedel' or 'goguen') or an instance of the S3 class [algebra()].
#' @return A two-argument function, which expects two numeric vectors of equal length
#'   (the vector elements are recycled to ensure equal lengths). The first argument, x,
#'   is a vector of membership degrees to be measured, the second argument, w, is
#'   the vector of weights.
#'
#'   Let \eqn{U} be the set of input vector indices (1 to length(x)). Then the sugeno integral
#'   computes the truth values accordingly to the following formula:
#'   \eqn{\vee_{z \subseteq U} \wedge_{u \in z} (x[u]) CONJ measure(m_z)},
#'   where
#'   \eqn{m_z = sum(w[z]) / sum(w)} if relative==TRUE or \eqn{m_z = sum(w)} if relative==FALSE
#'   and where CONJ is a strong conjunction (i.e. alg$pt) or a weak conjunction #' (i.e. alg$pi) accordingly to the strong parameter.
#' @author Michal Burda
#' @keywords models robust
#' @seealso [quantifier()], [lingexpr()]
#' @examples
#'   # Dvorak <1> "almost all" quantifier
#'   q <- sugeno(lingexpr(ctx3(), atomic='bi', hedge='ex'))
#'   a <- c(0.9, 1, 1, 0.2, 1)
#'   q(x=a, w=1)
#'
#'   # Dvorak <1,1> "almost all" quantifier
#'   a <- c(0.9, 1, 1, 0.2, 1)
#'   b <- c(0.2, 1, 0, 0.5, 0.8)
#'   q <- sugeno(lingexpr(ctx3(), atomic='bi', hedge='ex'))
#'   q(x=lukas.residuum(a, b), w=1)
#'
#'   # Murinová <1,1> "almost all" quantifier
#'   a <- c(0.9, 1, 1, 0.2, 1)
#'   b <- c(0.2, 1, 0, 0.5, 0.8)
#'   q <- sugeno(lingexpr(ctx3(), atomic='bi', hedge='ex'))
#'   q(x=lukas.residuum(a, b), w=a)
#' @export
sugeno <- function(measure,
relative=TRUE,
strong=FALSE,
alg=c('lukasiewicz', 'goedel', 'goguen')) {
.mustBeFunction(measure)
.mustBeLogicalScalar(relative)
.mustBeLogicalScalar(strong)
if (is.character(alg)) {
alg <- match.arg(alg)
alg <- algebra(alg)
}
.mustBe(is.algebra(alg), "'alg' must be either one of 'goedel', 'goguen', lukasiewicz', or an instance of class 'algebra'")

relate <- if (relative) function(u) { u / u[length(u)] } else identity
conj <- if (strong) alg$pt else alg$pi

function(x, w=1) {
.mustBeNumericVector(x)
.mustBeNumericVector(w)
.mustBe(all(!is.na(w)), "The 'w' argument must not contain NAs")

l <- max(length(x), length(w))
x <- rep_len(x, l)
w <- rep_len(w, l)
o <- alg$order(x, decreasing=TRUE) m <- measure(relate(cumsum(w[o]))) alg$s(conj(x[o], m))
}
}


## Try the lfl package in your browser

Any scripts or data that you put into this service are public.

lfl documentation built on Sept. 8, 2022, 5:08 p.m.