Nothing
### FuzzyR - Fuzzy Membership Functions
#' @title Fuzzy membership function generator
#' @description
#' To generate the corresponding membership function f(x), also called fuzzy set,
#' according to type and parameters
#' @param mf.type The membership function type
#' @param mf.params The parameters for a membership function
#' @details
#' Built-in membership function types are: 'gbellmf', 'it2gbellmf', 'singletonmf', 'linearmf', 'gaussmf', 'trapmf', 'trimf'.
#' \cr \cr mf.params for
#' \itemize{
#' \item 'gbellmf' is c(\code{a, b, c}), where \code{a} denotes the width, \code{b} is usually positive and {c} locates the center of the curve.
#' \cr \item 'it2gbellmf' is c(\code{a.lower, a.upper, b, c}), where \code{a.upper > a.lower} when \code{b > 0} and \code{a.upper < a.lower} when \code{b < 0}
#' \cr \item 'singletonmf' is c(\code{c}), where \code{c} is the location where the membership grade is 1.
#' \cr \item 'linearmf' is c(\code{...}), which are the coefficients of the linear membership function.
#' \cr \item 'gaussmf' is c(\code{sig, c}), which are the parameters for exp(-(x - c)^2/(2 * sig^2)).
#' \cr \item 'trapmf' is c(\code{a, b, c, d}), where \code{a} and \code{d} locate the "feet" of the trapezoid and \code{b} and \code{c} locate the "shoulders".
#' \cr \item 'trimf' is c(\code{a, b, c}), where \code{a} and \code{c} locate the "feet" of the triangle and \code{b} locates the peak.
#' }
#' Note that users are able to define their own membership functions.
#' @return The desired type of membership function f(x),
#' where x is a generic element of U, which is the universe of discourse for a fuzzy set
#' @examples
#' mf <- genmf('gbellmf', c(1,2,3))
#' evalmf(1:10, mf)
#' @author Chao Chen
#' @export
genmf <- function(mf.type, mf.params) {
FUN <- match.fun(mf.type)
FUN(mf.params)
}
#' @title Evaluate fuzzy membership function with membership function type and parameters
#' @description
#' To obtain the corresponding membership grade(s) for crisp input(s) x
#' @param x A generic element of U, which is the universe of discourse for a fuzzy set
#' @param mf.type The member function type
#' @param mf.params The parameters for a member function
#' @return Membership grade(s)
#' @examples
#' evalmftype(5, mf.type=gbellmf, mf.params=c(1,2,3))
#' evalmftype(1:10, mf.type=gbellmf, mf.params=c(1,2,3))
#' @author Chao Chen
#' @export
evalmftype <- function(x, mf.type, mf.params) {
MF <- genmf(mf.type, mf.params)
sapply(c(MF), function(F) F(x))
}
#' @title Evaluate fuzzy membership function
#' @description
#' To obtain the corresponding membership grade(s) for given crsip input(s) x
#'
#' @param ... For singleton fuzzification: x, mf.type, mf.params; x, mf. \cr Four additional parameters need to be used for non-singleton fuzzification: fuzzification.method, fuzzification.params, firing.method and input.range.
#' See details below for more information.
#' @details
#' * x - the crisp input(s) on the universe of discourse for corresponding antecedent membership function \cr
#' * mf.type - The type of fuzzy membership function\cr
#' * mf.params - The parameters for the given type of membership function\cr
#' * mf - the membership function generated by \code{\link{genmf}}
#' * fuzzification.method, fuzzification.params, firing.method and input.range - see \code{\link{addvar}}
#'
#' Usage:
#' 1. evalmf(x, mf.type, mf.params)
#' 1. evalmf(x, mf)
#' 1. evalmf(x, mf.type, mf.params, fuzzification.method, fuzzification.params, firing.method, input.range)
#' 1. evalmf(x, mf, fuzzification.method, fuzzification.params, firing.method, input.range )
#' @return Membership grade(s)
#' @examples
#' evalmf(5, mf.type=gbellmf, mf.params=c(1,2,3))
#' evalmf(1:10, mf.type=gbellmf, mf.params=c(1,2,3))
#' evalmf(1:10, mf.type=gbellmf, mf.params=c(1,2,3), fuzzification.method='gauss',
#' fuzzification.params=1, firing.method='tnorm.min.max', input.range=c(0,10))
#'
#' mf <- genmf('gbellmf', c(1,2,3))
#' evalmf(5, mf)
#' evalmf(1:10, mf)
#' evalmf(1:10, mf, fuzzification.method='gauss', fuzzification.params=1,
#' firing.method='tnorm.min.max', input.range=c(0,10))
#' @author Chao Chen
#' @export
#' @md
evalmf <- function(...) {
params <- list(...)
params.len <- length(params)
x <- params[[1]]
if (params.len == 3) {
MF <- genmf(mf.type = params[[2]], mf.params = params[[3]])
} else if (params.len == 2) {
MF <- params[[2]]
} else if (params.len == 6 || params.len == 7) {
return(evalmf.ns(...))
}
else {
stop("incorrect parameters")
}
sapply(c(MF), function(F) F(x))
}
evalmf.ns <- function(...) {
params <- list(...)
params.len <- length(params)
# x can be a single input or multiple inputs, as used in evalmf
x <- params[[1]]
if (params.len == 7) {
# MF: the antecedent membership function to be evaluated with inputs x
MF <- genmf(mf.type = params[[2]], mf.params = params[[3]])
} else if (params.len == 6) {
MF <- params[[2]]
} else {
stop("incorrect number of parameters")
}
# idx: params index for fuzzification.method
idx <- params.len - 3
fuzzification.method <- paste0(params[[idx]], '.fuzzification')
fuzzification.params <- params[[idx + 1]]
# X: fuzzified inputs based on non-singleton fuzzification
X <- sapply(x, x.fuzzification, f = fuzzification.method, m = fuzzification.params)
firing.method <- params[[idx + 2]]
# x.range: the domain of discourse for the input variable
x.range <- params[[idx + 3]]
tmp <- unlist(strsplit(firing.method, "\\."))
if (length(tmp) == 3 && tmp[1] == 'tnorm' && tmp[3] == 'max') {
tnorm.operator <- tmp[2]
result <- sapply(X, fuzzy.firing, operator = tnorm.operator, ante.mf = MF, lower = x.range[1], upper = x.range[2])
} else if (tmp[1] == 'tnorm' && tmp[3] == 'defuzz') {
tnorm.operator <- tmp[2]
defuzz.type <- tmp[4]
result <- sapply(X, fuzzy.firing.defuzz, operator = tnorm.operator, ante.mf = MF, lower = x.range[1], upper = x.range[2], defuzz.type)
} else if (tmp[1] == 'similarity') {
similarity.type <- tmp[2]
fuzzy.firing.fun <- match.fun(paste0('fuzzy.firing.similarity.', similarity.type))
result <- sapply(X, fuzzy.firing.fun, ante.mf = MF, lower = x.range[1], upper = x.range[2])
} else {
stop(paste0("firing.method '", firing.method, "' is not supported"))
}
# TODO: to be tested for IT2 membership functions
if (length(result) > 1) {
result <- as.matrix(result)
}
result
}
#' @title Generalised bell membership function
#' @description
#' To specify a generalised bell membership function with a pair of particular parameters
#' @param mf.params The parameters c(a, b, c) for a generalised bell membership function
#' @return The generalised bell membership function of x for a given pair of parameters,
#' where x is a generic element of U, which is the universe of discourse of a fuzzy set X
#' @details
#' This is not an external function. It should be used through \code{\link{genmf}}.
#' @examples
#' mf <- gbellmf(c(1,2,3))
#' # This is the same as:
#' mf <- genmf('gbellmf', c(1,2,3))
#'
#' evalmf(5, mf)
#' @author Chao Chen
#' @export
gbellmf <- function(mf.params) {
if (length(mf.params) != 3 && length(mf.params) != 4) {
stop("improper parameters for generalised bell membership function")
}
a <- mf.params[1]
b <- mf.params[2]
c <- mf.params[3]
if (length(mf.params) == 4) {
h <- mf.params[4]
} else {
h <- 1
}
gbellmf <- function(x) {
h / (1 + (((x - c) / a)^2)^b)
}
}
#' @title Generalised bell fuzzification
#' @description
#' To generate a fuzzy membership function based on generalised bell fuzzification for the given crisp input x
#' @param x the crisp input, which will be the parameter c for a generalised bell membership function
#' @param mf.params the parameters c(a, b) or c(a, b, h) for a generalised bell membership function
#' @return The gbell MF centred at the crisp point x
#' @examples
#' mf <- gbell.fuzzification(3, c(1,2))
#' # This is the same as:
#' mf <- genmf('gbellmf', c(1,2,3))
#'
#' evalmf(1:10, mf)
#' @author Chao Chen
#' @export
gbell.fuzzification <- function(x, mf.params) {
if (length(mf.params) != 2 && length(mf.params) != 3) {
stop("improper parameters for gbellmf fuzzification")
}
mf.params <- append(mf.params, x, 2)
genmf('gbellmf', mf.params)
}
## Function: it2gbellmf
## Description:
## to specify a interval type-2 generalised bell membership function with a pair of particular parameters
## Input:
## mf.params: the parameters c(a.lower, a.upper, b, c) for a generalised bell membership function
## Output:
## the lower and upper generalised bell membership function of x for a given pair of parameters
## , where x is a generic element of U, which is the universe of discourse of a fuzzy set X
it2gbellmf <- function(mf.params) {
if (length(mf.params) != 4 && length(mf.params) != 6) {
stop("improper parameters for generalised bell membership function")
}
a.lower <- mf.params[1]
a.upper <- mf.params[2]
b <- mf.params[3]
c <- mf.params[4]
if (length(mf.params) == 6) {
h.lower <- mf.params[5]
h.upper <- mf.params[6]
} else {
h.lower <- 1
h.upper <- 1
}
it2gbellmf.lower <- function(x) {
h.lower / (1 + (((x - c) / a.lower)^2)^b)
}
it2gbellmf.upper <- function(x) {
h.upper / (1 + (((x - c) / a.upper)^2)^b)
}
it2gbellmf <- c(it2gbellmf.lower, it2gbellmf.upper)
}
## Function: it2gbell.fuzzification
## Description:
## to make a interval type-2 generalised bell fuzzification to the crisp input
## Input:
## x: the crisp input, which will be the parameter c for a generalised bell membership function
## mf.params: the parameters c(a.lower, a.upper, b) for a generalised bell membership function
## Output:
## the lower and upper generalised bell membership function of x for a given pair of parameters
## , where x is a generic element of U, which is the universe of discourse of a fuzzy set X
it2gbell.fuzzification <- function(x, mf.params) {
if (length(mf.params) != 3 && length(mf.params) != 5) {
stop("improper parameters for it2gbellmf fuzzification")
}
mf.params <- append(mf.params, x, 3)
genmf('it2gbellmf', mf.params)
}
#' @title Singleton membership function
#' @description
#' To specify a singleton membership function at the particular point
#' @param mf.params the particular singleton point
#' @return The singleton membership function of x at the particular point,
#' where x is a generic element of U, which is the universe of discourse of a fuzzy set X
#' @details
#' This is not an external function. It should be used through \code{\link{genmf}}.
#' @examples
#' mf <- singletonmf(3)
#' # This is the same as:
#' mf <- genmf('singletonmf', 3)
#'
#' evalmf(1:10, mf)
#' @author Chao Chen
#' @export
singletonmf <- function(mf.params) {
if (length(mf.params) != 1 && length(mf.params) != 2) {
stop("improper parameters for singleton membership function")
}
x.prime <- mf.params[1]
if (length(mf.params) == 2) {
h <- mf.params[2]
} else {
h <- 1
}
singletonmf <- function(x) {
ifelse(x == x.prime, h, 0)
}
}
#' @title Singleton Fuzzification
#' @description
#' To generate a fuzzy membership function based on singleton fuzzification for the given crisp input x
#' @param x the crisp input
#' @param mf.params NULL or h
#' @return The singleton MF at the crisp point x
#' @examples
#' mf <- singleton.fuzzification(3)
#' evalmf(1:10, mf)
#' @author Chao Chen
#' @export
singleton.fuzzification <- function(x, mf.params = NULL) {
if (!is.null(mf.params) && length(mf.params) != 1) {
stop("improper parameters for singleton fuzzification")
}
mf.params <- c(x, mf.params)
genmf('singletonmf', mf.params)
}
#' @title Linear membership function
#' @description
#' To specify a 1st order linear membership function with given parameters
#' @param mf.params The linear parameters, which is a vector of the size of input numbers plus 1
#' @return A linear membership function
#' @author Chao Chen
#' @export
linearmf <- function(mf.params) {
if (length(mf.params) < 2) {
stop("improper parameters for linear membership function")
}
linearmf <- function(x) {
x %*% mf.params
}
}
gaussmf <- function(mf.params) {
sig <- mf.params[1]
c <- mf.params[2]
if (length(mf.params) == 3) {
h <- mf.params[3]
} else {
h <- 1
}
gaussmf <- function(x) {
exp(-(x - c)^2 / (2 * sig^2)) * h
}
}
gauss.fuzzification <- function(x, mf.params) {
if (length(mf.params) != 1 && length(mf.params) != 2) {
stop("improper parameters for gaussmf fuzzification")
}
mf.params <- append(mf.params, x, 1)
genmf('gaussmf', mf.params)
}
it2gaussmf <- function(mf.params) {
if (length(mf.params) != 4 && length(mf.params) != 6) {
stop("improper parameters for it2gaussmf membership function")
}
sig.lower <- mf.params[1]
c.lower <- mf.params[2]
sig.upper <- mf.params[3]
c.upper <- mf.params[4]
if (length(mf.params) == 6) {
h.lower <- mf.params[5]
h.upper <- mf.params[6]
} else {
h.lower <- 1
h.upper <- 1
}
it2gaussmf.lower <- function(x) {
exp(-(x - c.lower)^2 / (2 * sig.lower^2)) * h.lower
}
it2gaussmf.upper <- function(x) {
exp(-(x - c.upper)^2 / (2 * sig.upper^2)) * h.upper
}
it2gaussmf <- c(it2gaussmf.lower, it2gaussmf.upper)
}
trapmf <- function(mf.params) {
a <- mf.params[1]
b <- mf.params[2]
c <- mf.params[3]
d <- mf.params[4]
if (length(mf.params) == 5) {
h <- mf.params[5]
} else {
h <- 1
}
trapmf <- function(x) {
y <- pmax(pmin((x - a) / (b - a), h, (d - x) / (d - c)), 0)
y[is.na(y)] = h; y
}
}
it2trapmf <- function(x, mf.params) {
if (length(mf.params) != 8 && length(mf.params) != 10) {
stop("improper parameters for it2gaussmf membership function")
}
a.lower <- mf.params[1]
b.lower <- mf.params[2]
c.lower <- mf.params[3]
d.lower <- mf.params[4]
a.upper <- mf.params[5]
b.upper <- mf.params[6]
c.upper <- mf.params[7]
d.upper <- mf.params[8]
if (length(mf.params) == 10) {
h.lower <- mf.params[9]
h.upper <- mf.params[10]
} else {
h.lower <- 1
h.upper <- 1
}
it2trapmf.lower <- function(x) {
y <- pmax(pmin((x - a.lower) / (b.lower - a.lower), h.lower, (d.lower - x) / (d.lower - c.lower)), 0)
y[is.na(y)] = h.lower; y
}
it2trapmf.upper <- function(x) {
y <- pmax(pmin((x - a.upper) / (b.upper - a.upper), h.upper, (d.upper - x) / (d.upper - c.upper)), 0)
y[is.na(y)] = h.upper; y
}
it2trapmf <- c(it2trapmf.lower, it2trapmf.upper)
}
trimf <- function(mf.params) {
a <- mf.params[1]
b <- mf.params[2]
c <- mf.params[3]
if (length(mf.params) == 4) {
h <- mf.params[4]
} else {
h <- 1
}
trimf <- function(x) {
y <- h * pmax(pmin((x - a) / (b - a), (c - x) / (c - b)), 0)
y[is.na(y)] = h; y
}
}
it2trimf <- function(mf.params) {
a.lower <- mf.params[1]
b.lower <- mf.params[2]
c.lower <- mf.params[3]
a.upper <- mf.params[4]
b.upper <- mf.params[5]
c.upper <- mf.params[6]
if (length(mf.params) == 8) {
h.lower <- mf.params[7]
h.upper <- mf.params[8]
} else {
h.lower <- 1
h.upper <- 1
}
it2trimf.lower <- function(x) {
y <- h.lower * pmax(pmin((x - a.lower) / (b.lower - a.lower), (c.lower - x) / (c.lower - b.lower)), 0)
y[is.na(y)] = h.lower; y
}
it2trimf.upper <- function(x) {
y <- h.upper * pmax(pmin((x - a.upper) / (b.upper - a.upper), (c.upper - x) / (c.upper - b.upper)), 0)
y[is.na(y)] = h.upper; y
}
it2trimf <- c(it2trimf.lower, it2trimf.upper)
}
tri.fuzzification <- function(x, mf.params) {
if (length(mf.params) != 2 && length(mf.params) != 3) {
stop("improper parameters for trimf fuzzification")
}
mf.params <- append(mf.params, x, 1)
genmf('trimf', mf.params)
}
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.