Nothing
# This variable is for fix precision errors in numeric comparisons using the operator '==', '<=' or '>='
.tolerance <- 1e-10
#
#
# This function creates all the fuzzy intervals for a dataset
#
#
.create_fuzzyIntervals <- function(min, max, num_sets, types){
n_mats <- length(min)
#Creates the fuzzy intervals for each variable
lst <- lapply(X = 1:n_mats, FUN = function(x) .FuzzyIntervals(min = min[x], max = max[x], num_sets = num_sets, types = types[x]))
#Collect on an array
arr <- do.call(cbind, lst)
dim(arr) <- c(num_sets, 3, n_mats)
arr
}
#
#
# Function to create fuzzy intervals over a single variable.
#
#
.FuzzyIntervals <- function(min, max, num_sets, types){
xmin <- min - ( (max - min) / (num_sets - 1) )
xmedio <- min
xmax <- 0
fuzzySet <- matrix(nrow = num_sets, ncol = 3)
for(j in 1:num_sets){ # For each fuzzy set
if(types != "c"){ #If the variable is not categorical
xmax <- min + ( (max - min) / (num_sets - 1) ) * j
#Save fuzzy set
fuzzySet[j, 1] <- xmin
fuzzySet[j, 2] <- xmedio
fuzzySet[j, 3] <- xmax
#Modify variables to calculate the next set
xmin <- xmedio
xmedio <- xmax
}
}
#Return
fuzzySet
}
#-----------------------------------------------------------------------------------
# Creates crisp sets relative to the fuzzy sets generated before.
# This works because the fuzzy sets are all triangular and for a given fuzzy sets we know
# the exact cut point. If we implement another kind of fuzzy set, this method does not work anymore
#-----------------------------------------------------------------------------------
.createCrispIntervals <- function(fuzzyIntervals){
n_mat <- dim(fuzzyIntervals)[3]
n_vars <- dim(fuzzyIntervals)[1]
crispIntervals <- lapply(X = 1:n_mat, FUN = function(x, fuzzy) .CrispIntervals(fuzzy[,,x]) , fuzzyIntervals)
arr <- do.call(cbind, crispIntervals)
dim(arr) <- c(n_vars, 2, n_mat)
arr
}
#
#
# Create crisp sets for a single variable
#
#
.CrispIntervals <- function(fuzzyInterval){
n_vars <- dim(fuzzyInterval)[1] # each row of the matrix is a variable
crispMatrix <- matrix(nrow = n_vars, ncol = 2)
min <- fuzzyInterval[1,1]
# The maximum of the crisp sets is the mean point between 'xmin' and 'xmedio' for the first fuzzy sets
max <- (fuzzyInterval[1,3] + fuzzyInterval[1,2]) / 2
crispMatrix[1,1] <- min
crispMatrix[1,2] <- max
for(i in 2:n_vars){
# The maximum before is now the new minimum
min <- max
#For the second in advance, 'max' is the mean point between 'xmedio' and 'xmax' of the given set.
max <- (fuzzyInterval[i,3] + fuzzyInterval[i,2]) / 2
crispMatrix[i,1] <- min
crispMatrix[i,2] <- max
}
crispMatrix
}
#
#
# Compute the belonging degree of an entire example set for the specified
# fuzzy sets, this sets must be specified by means of their min, max
# and half value.
# If you want to get the belonging degree for a subset of variables,
# you must get only the values of the example corresponding to those variables
# before execute this function.
#
#
.fuzzyBelongingDegree <- function(x, xmin, xmedio, xmax, n_matrices){
x <- as.numeric(x)
result <- numeric(length(x)) + 1
#Sum the tolerance value to the values
xminX <- numeric(length(x)) + xmin + .tolerance
xmedioX <- numeric(length(x)) + xmedio + .tolerance
xmaxX <- numeric(length(x)) + xmax + .tolerance
#Calculate which values are out of bounds, are less than xmedio or greater then xmedio
#because each one have a diferente belonging degree computation
outOfBounds <- which( x <= xminX | x >= xmaxX )
lessXMedio <- which( x < xmedioX & x > xminX )
greaterXMedio <- which( x > xmedioX & x < xmaxX )
#Calculate the belonging degree (TRIANGULAR SETS ONLY !)
result[outOfBounds] <- 0
result[lessXMedio] <- (( x[lessXMedio] - xminX[lessXMedio] ) * (1 / (xmedioX[lessXMedio] - xminX[lessXMedio] )))
result[greaterXMedio] <- (( xmaxX[greaterXMedio] - x[greaterXMedio] ) * (1 / (xmaxX[greaterXMedio] - xmedioX[greaterXMedio] )))
result <- matrix(result, ncol = n_matrices, byrow = TRUE)
result
}
#
#
# It is like fuzzyBelongingDegree but for crisp belonging and you must specify the min and max
# value for crisp sets
#
#
.crispBelongingDegree <- function(x, xmin, xmax, DNF = FALSE){
x <- as.numeric(x)
result <- numeric(length(x))
#Gets elements inside crisp sets bounds
resulta <- which((x > xmin + .tolerance) & x <= (xmax + .tolerance))
#Assing value of 1 to elements inside bounds
result[resulta] <- 1
result <- matrix(result, ncol = length(xmax), byrow = TRUE)
result
}
#
#
# Return the fuzzy belonging degree for a DNF rule
#
#
.getMaxFuzzyForAVariable2 <- function(values, example_num){
#Return fuzzy belonging degree of each value-variable
result <- .fuzzyBelongingDegree(x = as.vector(example_num), xmin = values[2,], xmedio = values[3,], xmax = values[4,], n_matrices = NCOL(values))
a <- which(!duplicated(values[1,]))
long <- length(a)
rangos <- vector(mode = "list", length = long)
for(i in seq_len(long)){
if(! is.na(a[i +1 ])){
rangos[[i]] <- a[i]:(a[i + 1] - 1)
} else {
rangos[[i]] <- a[i]:NCOL(result)
}
}
# Calculate the fuzzy belonging degree as the minimum of each variable. The value of each variable is the maximum
# belonging degree of a value that participate in the rule
if(NCOL(result) > 1){
result <- t( apply(X = result, MARGIN = 1, FUN = function(x, rangos) vapply(X = rangos, FUN = function(x, vector) max(vector[x]), FUN.VALUE = 1, x) , rangos) )
result <- apply(X = result, MARGIN = 1, FUN = min)
} else {
result <- t( apply(X = result, MARGIN = 1, FUN = function(x, rangos) vapply(X = rangos, FUN = function(x, vector) max(vector[x]), FUN.VALUE = 1, x) , rangos) )
}
result
}
#
#
# The same but for crips set on DNF Rules
#
#
.getMaxCrispForAVariable2 <- function(values, example_num){
result <- .crispBelongingDegree(x = as.vector(example_num), xmin = values[2,], xmax = values[3,], DNF = TRUE)
a <- which(!duplicated(values[1,]))
long <- length(a)
rangos <- vector(mode = "list", length = long)
for(i in seq_len(long)){
if(! is.na(a[i +1 ])){
rangos[[i]] <- a[i]:(a[i + 1] - 1)
} else {
rangos[[i]] <- a[i]:NCOL(result)
}
}
if(NCOL(result) > 1){
result <- t( apply(X = result, MARGIN = 1, FUN = function(x, rangos) vapply(X = rangos, FUN = function(x, vector) max(vector[x]), FUN.VALUE = 1, x) , rangos) )
result <- apply(X = result, MARGIN = 1, FUN = min)
} else {
result <- t( apply(X = result, MARGIN = 1, FUN = function(x, rangos) vapply(X = rangos, FUN = function(x, vector) max(vector[x]), FUN.VALUE = 1, x) , rangos) )
}
result
}
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.