R/FuzzyMF.R

In FuzzyR: Fuzzy Logic Toolkit for R

### 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)
}