Nothing
# Verify data types
#' @noRd
verifyNumbersFunction <- function(dados, cols){
resul <- sapply(1:cols, function(i){
n = 3
subset <- sample(dados[,i],size = n, replace = F)
result <- ceiling(subset) == floor(subset) # check if the variable is discrete
resulsum <- ifelse(sum(result) == n, 1, 0)
return(resulsum)
})
return(resul)
}
# Verify Columns
#' @noRd
verifyColumns <- function(dados){
cols <- ncol(dados)# Number of variables
if(is.null(cols) | cols == 0){
cols <- 1
}
return(cols)
}
# PreData
#' @noRd
predata <- function(dados,cl){
train <- as.data.frame(dados)
cols <- verifyColumns(train)
M <- c(unlist(cl)) # true classes
M <- factor(M, labels = sort(unique(M)))
intervalos <- 10 # Division to memberships
lista = list(train = train,
dados = dados,
cols = cols,
M = M,
intervalos = intervalos)
return(lista)
}
#---- Sturges -----#
#' @noRd
Sturges <- function(dados, M) {
Output <- lapply(1:length(unique(M)), function(i) {
SubSet <- dados[M == unique(M)[i], ]
if(ncol(dados) == 1){
return(round(sqrt(length(SubSet))))
}else{
return(round(sqrt(nrow(SubSet))))
}
})
return(Output)
}
#' @noRd
Sturges_discrete <- function(dados, M) {
Output <- lapply(1:length(unique(M)), function(i) {
SubSet <- dados[M == unique(M)[i], 1]
if(ncol(dados) == 1){
return((length(unique(SubSet))))
}else{
return((length(unique(SubSet))))
}
})
return(Output)
}
#---- Range Length ----#
#' @noRd
Comprim_Intervalo <- function(dados, M, Sturges) {
Output <- lapply(1:length(unique(M)), function(i) {
SubSet <- dados[M == unique(M)[i], ]
if(ncol(dados) == 1){
comp <- (max(SubSet) - min(SubSet)) / Sturges[[i]]
}else{
comp <- (apply(SubSet, 2, max) - apply(SubSet, 2, min)) / Sturges[[i]]
}
})
return(Output)
}
#' @noRd
Comprim_Intervalo_discrete <- function(dados,M){
Output <- lapply(1:length(unique(M)),function(i){
rep(1,ncol(dados))
})
return(Output)
}
#--------------------------------------------------------
#' @noRd
minimos <- function(dados, M, cols) {
Output <- lapply(1:length(unique(M)), function(i) {
sapply(1:cols, function(j) {
SubSet <- dados[M == unique(M)[i], ]
if (ncol(dados) == 1){
return(min(SubSet))
}else{
return(min(SubSet[, j]))
}
})
})
return(Output)
}
#---------------
#---------------
#' @noRd
maximos <- function(dados, M, cols) {
Output <- lapply(1:length(unique(M)), function(i) {
sapply(1:cols, function(j) {
SubSet <- dados[M == unique(M)[i], ]
if (ncol(dados) == 1){
return(max(SubSet))
}else{
return(max(SubSet[, j]))
}
})
})
return(Output)
}
#---------------
#' @noRd
Freq <- function(dados, M, Comprim_Intervalo, Sturges, minimos, cols) {
#--------------------------------------------------------
Freq <- lapply(1:length(unique(M)), function(i) {
ara <- array(0, dim = c(Sturges[[i]], cols))
return(ara)
})
for (classe in 1:length(unique(M))) {
# --
SubSet <- dados[M == unique(M)[classe], ]
SubSet <- as.data.frame(SubSet)
NN = nrow(SubSet)
# --
for (coluna in 1:cols) { # class column
for (linhaClasse in 1:NN) { # class row
faixa <- minimos[[classe]][coluna] + Comprim_Intervalo[[classe]][coluna] # initial frequency band
for (linhaFreq in 1:Sturges[[classe]]) { # frequency line
# --
if (SubSet[linhaClasse, coluna] < faixa) { # checks if the class value belongs to that range
Freq[[classe]][linhaFreq, coluna] <- Freq[[classe]][linhaFreq, coluna] + 1 # accumulates value in the frequency range and interrupts this last 'for'
break
}
if (linhaFreq == Sturges[[classe]] && SubSet[linhaClasse, coluna] >= faixa) {
Freq[[classe]][linhaFreq, coluna] <- Freq[[classe]][linhaFreq, coluna] + 1
break
}
faixa <- faixa + Comprim_Intervalo[[classe]][coluna] # track change -> next
}
}
}
}
#----------
return(Freq)
#----------
}
#' @noRd
Intervalos_Valores <- function(dados, M, Comprim_Intervalo, Sturges, minimos, cols) {
#--------------------------------------------------------
Freq <- lapply(1:length(unique(M)), function(i) {
ara <- array(0, dim = c(Sturges[[i]], cols))
return(ara)
})
for (classe in 1:length(unique(M))) {
# --
SubSet <- dados[M == unique(M)[classe], ]
#train <- as.data.frame(train)
cols <- ncol(SubSet) # Number of variables
if(is.null(cols)){
cols <- 1
SubSet <- as.data.frame(SubSet)
}
# --
for (coluna in 1:cols) { # class column
for (linhaClasse in 1:nrow(SubSet)) { # class row
faixaant <- minimos[[classe]][coluna]
faixa <- minimos[[classe]][coluna] + Comprim_Intervalo[[classe]][coluna] # initial frequency band
for (linhaFreq in 1:Sturges[[classe]]) { # frequency line
# --
Freq[[classe]][linhaFreq, coluna] <- paste0(round(faixaant,3),",",round(faixa,3));
# --
faixaant <- faixa
faixa <- faixa + Comprim_Intervalo[[classe]][coluna] # track change -> next
}
}
}
}
#----------
return(Freq)
#----------
}
#--------------------------------------------------------
#---- Pertinencia ----#
#' @noRd
Pertinencia <- function(Freq, dados, M) {
dados <- as.data.frame(dados)
Output <- lapply(1:length(unique(M)), function(i) {
if(ncol(dados) == 1){
NN = length(dados[M == unique(M)[i], ])
}else{
NN = nrow(dados[M == unique(M)[i], ])
}
Freq[[i]] / NN
})
return(Output)
}
#' @noRd
pertinencia_predict <- function(M, Sturges, minimos, Comprim_Intervalo, Pertinencia, cols, x){
#---------------
ACHOU_t <- c()
ACHOU <- 0
#---------------
for (classe in 1:length(unique(M))) {
# --
# --
for (coluna in 1:cols) { # class column
for (linhaF in 1:Sturges[[classe]]) { # class row
faixa <- minimos[[classe]][coluna] + Comprim_Intervalo[[classe]][coluna] # initial frequency band
if (x[[coluna]] < faixa) { # checks if the class value belongs to that range
ACHOU[coluna] <- Pertinencia[[classe]][linhaF, coluna] # accumulates value in the frequency range and interrupts this last 'for'
break
}
if (linhaF == Sturges[[classe]]) {
ACHOU[coluna] <- Pertinencia[[classe]][linhaF, coluna]
break
}
faixa <- faixa + Comprim_Intervalo[[classe]][coluna] # track change -> next
}
}
# ---
ACHOU_t <- rbind(ACHOU_t, ACHOU) # Classes are the lines
# ---
}
#-----
row.names(ACHOU_t) <- unique(M)
#--------------------------------------------------------
ACHOU_t <- apply(ACHOU_t, 1, prod)
return(ACHOU_t)
}
#' @noRd
pertinencia_predictDW <- function(M, Sturges, minimos, Comprim_Intervalo, Pertinencia, cols, x, weta){
#---------------
ACHOU_t <- c()
ACHOU <- 0
#---------------
for (classe in 1:length(unique(M))) {
# --
# --
for (coluna in 1:cols) { # class column
for (linhaF in 1:Sturges[[classe]]) { # class row
faixa <- minimos[[classe]][coluna] + Comprim_Intervalo[[classe]][coluna] # initial frequency band
if (x[coluna] < faixa) { # checks if the class value belongs to that range
ACHOU[coluna] <- weta[coluna]*Pertinencia[[classe]][linhaF, coluna] # accumulates value in the frequency range and interrupts this last 'for'
break
}
if (linhaF == Sturges[[classe]]) {
ACHOU[coluna] <- weta[coluna]*Pertinencia[[classe]][linhaF, coluna]
break
}
faixa <- faixa + Comprim_Intervalo[[classe]][coluna] # track change -> next
}
}
# ---
ACHOU_t <- rbind(ACHOU_t, ACHOU) # Classes são as linhas
# ---
}
#-----
row.names(ACHOU_t) <- unique(M)
#--------------------------------------------------------
ACHOU_t <- apply(ACHOU_t, 1, prod)
return(ACHOU_t)
}
# ----------------
#' @noRd
function_membership_predict <- function(x, M = M, Sturges = Sturges, minimos = minimos, Comprim_Intervalo = Comprim_Intervalo, Pertinencia = Pertinencia, cols = cols){
ACHOU_t <- pertinencia_predict(M, Sturges, minimos, Comprim_Intervalo, Pertinencia, cols, x);
return(ACHOU_t)
}
# ----------------
# ----------------
#' @noRd
function_membership_predict_dw <- function(x, M = M, Sturges = Sturges, minimos = minimos, Comprim_Intervalo = Comprim_Intervalo, Pertinencia = Pertinencia, cols = cols, weta = weta){
ACHOU_t <- pertinencia_predictDW(M, Sturges, minimos, Comprim_Intervalo, Pertinencia, cols, x, weta);
return(ACHOU_t)
}
# ----------------
# ----------------
#' @noRd
function_fuzzy_predict <- function(retorno, P, M){
retorno2 <- data.frame(matrix(unlist(retorno), nrow=length(retorno), byrow=TRUE))
f <- sapply(1:length(unique(M)), function(i) {
P[[i]] * retorno2[,i]
})
return(f)
}
# ----------------
# ----------------
#' @noRd
function_fuzzy_predict_log <- function(retorno, P, M){
retorno2 <- data.frame(matrix(unlist(retorno), nrow=length(retorno), byrow=TRUE))
f <- sapply(1:length(unique(M)), function(i) {
P[[i]] + log(retorno2[,i])
})
return(f)
}
# ----------------
#' @noRd
log_ver_Gamma <- function(theta,y){
# Gamma Likelihood Function
beta = theta[2]
alpha = theta[1]
saida <- - sum(dgamma(y,shape = alpha, scale = beta, log = T),na.rm=T)
return(saida)
}
#' Barycenter
#' Yager method
#' @noRd
Yagerdistance <- function(vec_trian, M){
value <- sapply(1:length(unique(M)), function(i) (vec_trian[[i]][1] + 2*vec_trian[[i]][2] + vec_trian[[i]][3]) / 4)
return(value)
}
#' Using distance Q
#' @noRd
Qdistance <- function(vec_trian, M){
# ------------
# Using distance Q
value <- sapply(1:length(unique(M)), function(i) {
# ------------
# Start 3 values
y <- vec_trian[[i]]
# ------------
# getting the product zz*
S <- y %*% t(Conj(y)) # matrix k x k
# ------------
# getting the eigenvalues
l <- eigen(S)$values
# Calculating Q
Q <- 3 * (l[1] - l[2])^2
# ------------
return(Q)
})
# ------------
return(value)
}
#' Thorani
#' Article: Ordering Generalized Trapezoidal Fuzzy Numbers Using Orthocentre of Centroids
#' "changes were made"
#' @noRd
Thoranidistance <- function(vec_trian, M){
# ------------
# Using distance Q
value <- sapply(1:length(unique(M)), function(i) {
(1/length(unique(M)))*
vec_trian[[i]][2] * ((vec_trian[[i]][2] - vec_trian[[i]][1])*(vec_trian[[i]][3] - vec_trian[[i]][2]) + 1)
})
return(value)
}
#' Alpha-Order for a class of fuzzy sets
#' Article: Alpha-Order for a class of fuzzy sets
#' "changes were made"
#' @noRd
AlphaOrderFuzzy <- function(vec_trian, w, M){
vec_mean <- lapply(1:length(vec_trian), function(i) rowMeans(vec_trian[[i]]))
# ------------
value <- sapply(1:length(unique(M)), function(i) {
sum(w*vec_mean[[i]],na.rm = T)
})
return(value)
}
# --------------------------------------------------------------------------
# New Pertinence Function
# --------------------------------------------
# Matriz Intervalos de Minimos
#' @noRd
minomosdt_function <- function(minimos, M, Comprim_Intervalo, Sturges, cols){
# --------------------------------------------
minomosdt <- lapply(1:length(unique(M)),function(i){
minim <- sapply(1:cols, function(j){
minimiosx <- c(minimos[[i]][j])
for(h in 2:(Sturges[[i]]+1)){
minimiosx[h] <- minimiosx[h-1] + Comprim_Intervalo[[i]][j]
}
return(minimiosx)
})
return(minim)
})
# --------------------------------------------
return(minomosdt)
}
# --------------------------------------------
`%>%` <- magrittr::`%>%`
# --------------------------------------------
# Frequencia - Matriz Esparsa
#' @noRd
Freq_esparsa <- function(dados, M, minomosdt, cols){
Freq_joda <- lapply(1:length(unique(M)), function(i){
Frequencia <- data.frame()
XX <- subset(dados, M == unique(M)[i])
for (t in 1:nrow(XX)){
x <- XX[t,]
vetor <- sapply(1:cols, function(j){
max(which(as.numeric(x[j]) >= minomosdt[[i]][,j]))
})
Frequencia <- rbind(Frequencia, c(vetor,1))
}
# --------------------------------------------
result <- Frequencia %>%
dplyr::group_by(Frequencia[,-(cols+1)]) %>%
dplyr::summarize(Freq = dplyr::n())
# --------------------------------------------
result <- data.frame(result)
return(result)
})
# --------------------------------------------
return(Freq_joda)
}
# --------------------------------------------
# --------------------------------------------
# Soma - Matriz Esparsa
#' @noRd
soma_freq <- function(M, Freq_joda, cols){
Soma_joda <- lapply(1:length(unique(M)), function(i){
result <- Freq_joda[[i]]
result[,(cols+1)] <- sum(Freq_joda[[i]][,(cols+1)])
return(result)
})
return(Soma_joda)
}
# --------------------------------------------
# --------------------------------------------
# Pertinencia - Matriz Esparsa
#' @noRd
Pertinencia_esparsa <- function(M, Freq_joda, cols){
# --------------------------------------------
Pert_joda <- lapply(1:length(unique(M)), function(i){
result <- Freq_joda[[i]]
result[,(cols+1)] <- Freq_joda[[i]][,(cols+1)]/sum(Freq_joda[[i]][,(cols+1)])
return(result)
})
# --------------------------------------------
return(Pert_joda)
}
# --------------------------------------------------------------------------
# --------------------------------------------------------------------------
# Pertinencia Predict - Matriz Esparsa
#' @noRd
pertinencia_predict_esparsa <- function(minomosdt, x, Pert_joda, cols,i){
vetor <- try(sapply(1:cols, function(j){
maximo <- which(as.numeric(x[j]) >= minomosdt[[i]][,j])
if(length(maximo)!=0){
return(max(maximo))
}else{
return(0)
}
}),silent = T)
if(any(0 %in% vetor)){
Pertinencia_r <- 2.2e-16
return(Pertinencia_r)
}else{
Perts <- Pert_joda[[i]]
if(cols ==1){
# Search for the position of the pertinence in vector
posicao <- which(Perts[,-(cols+1)] == vetor)
}else{
# Search for the position of the pertinence in sparse matrix
posicao <- which(apply(Perts[,-(cols+1)], 1, function(row) all(row == vetor)))
}
if(length(posicao) == 0){
Pertinencia_r <- 2.2e-16
return(Pertinencia_r)
}else{
Pertinencia_r <- Perts[posicao,(cols+1)]
return(Pertinencia_r)
}
}
}
# --------------------------------------------------------------------------
# ----------------
#' @noRd
function_new_membership_predict <- function(test, M = M, MinimosDataFrame, Pertinencia, cols = cols){
Pertinencia_r <- lapply(1:length(unique(M)), function(i){
sapply(1:nrow(test), function(j){
x <- test[j,]
pertinencia_predict_esparsa(minomosdt = MinimosDataFrame, x, Pert_joda = Pertinencia, cols,i)
})
})
return(Pertinencia_r)
}
# ----------------
# ----------------
#' @noRd
function_new_fuzzy_predict <- function(retorno, P, M){
f <- sapply(1:length(unique(M)), function(i) {
P[[i]] * retorno[[i]]
})
return(f)
}
# ----------------
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.