library(entropy);
#' @title Antminer
#' @description Algorytm do budowy modelu klasyfikacji oparty na algorytmie mrowkowym optymalizacji
#' @param data zbior danych do budowy modelu
#' @param class nazwa kolumny ze zbioru danych z wartosciami klas.
#' Algorytm zbuduje model do predykcji tych klas
#' @param maxUncoveredCases liczba niepokrytych przypadkow ze zbioru danych.
#' Algorytm bedzie pracowal dopoki liczba niepokrytych przypadkow jest wieksza od tej liczby
#' @param NumberOfAnts liczba tworzonych regul podczas jednej iteracji.
#' @param NumberOfRulesConverge liczba stworzonych regul podczas iteracji, ktore sie powtarzaja.
#' Algorytm konczy iteracje powyzej tej liczby.
#' @param MinCasesPerRule liczba pokrytych przypadklw przez zbudowana regule.
#' Jesli regula pokrywa mniej to jest odrzucana.
#' @details
#' Algorytm w kazdej iteracji tworzy maksymalnie NumberOfAnts regul na podstawie aktualnego zbioru danych.
#' Regula jest dodawana do zbioru regul jesli pokrywa co najmniej MinCasesPerRule przypadkow.
#' Ze zbioru stworzonych regul wybierana jest jedna regula, najlepsza pod wzgledem jakosci. Przypadki pokrywane przez ta regule sa usuwane ze zbioru danych.
#' Algorytm moze wczesniej zakonczyc iteracje jesli liczba zduplikowanych regul ktore stworzyl przekroczy wartosc NumberOfRulesConverge.
#' Jesli algorytm ciagle tworzy zduplikowane reguly to znaczy ze tak juz sie dostosowal i nie ma sensu tworzyc kolejnych regul, zatem konczymy iteracje.
#' Algorytm bedzie wykonywal kolejne iteracje jesli liczba przypadkow ze zbioru danych jest wieksza niz maxUncoveredCases.
#' Stworzony model ma forme listy uporzadkowanych regul. Od pierwszej znalezionej reguly do ostatniej znalezionej reguly.
#' Wnioskowanie klasy na podstawie modelu polega na znalezieniu regyly ktora pokrywa przypadek i ustawieniu klasy z tego przypadku.
#' Wazne jest to, ze pierwsza regula ktora pokrywa przyklad jest wybierana, nie sa przegladane inne reguly ktore moga lepiej pokrywac przyklad.
#' W modelu ustawiana jest takze klasa domyslna, jest to dominujaca klasa z niepokrytych przypadkow.
#' @return Model skladajacy sie z listy abudowanych regul
#' @examples
#' model <- antminer(trainingSet, "Class", 10, 100, 15, 1)
#' pred <- predict(model, testSet)
antminer3 <- function(trainingSet,class, maxUncoveredCases, NumberOfAnts, NumberOfRulesConverge, MinCasesPerRule) {
#przenies kolumne z atrybutami decyzyjnymi na sam koniec dataframe
cls <- trainingSet[class]
trainingSet[class]<-NULL
trainingSet[class]<-cls
cls<-NULL
#wyznacz zbior treningowy bez kolumny z atrybutami decyzyjnymi
#usuwa ostatnia kolumne
trainingSetWithoutClass<-subset(trainingSet, select= -c(length(trainingSet)))
nr_of_class<-length(unique(trainingSet[,class]))
#wyznacz wszystkie termy (pary atrybut-wartosc)
terms <- getTerms(trainingSetWithoutClass)
#wyznacz entropie dla kazdego termu
entropies<-computeEntropy(terms, trainingSet, class)
#na poczatku lista regul jest pusta
discoveredRules <- list()
while(nrow(trainingSet) > maxUncoveredCases) {
print(nrow(trainingSet))
#numer mrowki
i <- 1;
#indeks testu zbieznosci
j <- 1;
#lista utworzonych regul, na poczatku pusta
rules<-list()
#wektor jakosci regul, zeby wiedziec ktora regula jest najlepsze
#sposrod wszystkich stworzonych
qualities<-list()
#inicjalizacja sciezek ta sama iloscia feromonu
pheromones <- initPheromone(terms)
#powtarzamy az wykorzystamy wszystkie mrowki
#albo gdy przekroczymy indeks zbierznosci
while( (i<NumberOfAnts) & (j<NumberOfRulesConverge) ) {
print("mrowka")
print(i)
#regula to lista skladajaca sie z dwoch list
#pierwsza lista to zbior termow tworzacych regule
#druga lista przechowuje atrybuty (w kolejnosci) wykorzystane w regule
rule <- build_rule(trainingSet, terms, MinCasesPerRule, class, nr_of_class, entropies, pheromones)
#jesli regula jest null to znaczy ze nie spelnila warunku MinCasesPerRule
#w takim przypadku juz wiecej regul nie powstanie
if(is.null(rule)) {
break
}
#po wybudowaniu reguly przycinamy ja
rule <- prune(rule, trainingSet, class)
rule_quality<-quality(rule, trainingSet, class)
#zwiekszamy feromon
pheromones<-increasePheromone(rule, pheromones, rule_quality)
#zmiejszamy feromon
pheromones<-decreasePheromone(pheromones)
#Lepiej zmianic na wykrywanie czy stworzyl jakas nowa regule
#w n poprzednich krokach niz to
if(isEqualRule(rule, rules)) {
j <- j+1;
} else {
j <- 1;
rules[[length(rules)+1]]<-rule
qualities[[length(qualities)+1]]<-rule_quality
}
i<-i+1;
}
#jesli lista regul jest pusta to znaczy ze algorytm nie potrafil podczas
#NumberOfAnts prób stworzyc reguly
#dzieje sie tak zwykle gdy liczba przypadkow jest zbyt mala dla pewnych parametrow
#algorytmu, w takim przypadku nalezy zakonczyc algorytm
if(length(rules)>0) {
ab<-which.max(qualities)
bestRule <- rules[[which.max(qualities)]]
discoveredRules[[length(discoveredRules)+1]]<-bestRule
trainingSet<-uncoveredCases(bestRule, trainingSet, class)
} else {
break;
}
}
defaultClass <- majorClass2(trainingSet, class)
model <- list(discoveredRules, defaultClass)
class(model)<-"antminer"
return(model)
}
#zwraca wszystkie termy na podstawie danych treningowych
#dane treningowe musza byc bez kolumny z atrybutem decyzyjnym
#bo w innym razie zwrocilby takze termy w postaci atrybutow decyzyjnych
getTerms<-function(trainingSet) {
#zwraca unikalne wartości z każdej kolumny danych treningowych
#2 oznacza ze operuje na kolumnach, 1 by oznaczala ze na wierszach
terms<-apply(trainingSet, 2, unique)
#lapply(terms, function(x) {sapply(x, function(term) {namedTerm(term, x)})})
#lapply(terms, function(x) {sapply(x, function(term) {term}, USE.NAMES = FALSE)})
lapply(1:length(terms), function(x) {lapply(terms[[x]], function(term) {namedTerm(term, terms[x])})})
}
namedTerm<-function(term, terms) {
names(term)<-names(terms)
term
}
#Zwraca obliczona entropie dla kazdej pary atrybut-wartosc
#pierwszy terms oznacza liste list wszystkich atrybutow
#drugie terms oznacza liste atrybutu (jednego), czyli wartosci tego atrybutu
computeEntropy <- function(terms, data, class) {
mapply(function(terms, index) {sapply(terms, function(x) {entropy(x, index, data, class)})}, terms, 1:length(terms))
}
#oblicza entropie danego terma, czyli entropie pary atrybut-wartosc
entropy <- function(term, col, data, class) {
cases <- data[which(data[col]==term),class]
freqs <- table(cases)/length(cases)
entropy.empirical(freqs, unit="log2");
}
#poczatkowy feromon to 1/liczba_wszystkich_wartosci (liczba wszystkich termow)
#liczba odwrotnie proporcjonalna do liczby wartości wszystkich atrybutow
initPheromone <- function(terms) {
initialPheromone <- 1/length(unlist(terms))
#lapply(terms, function(x) {sapply(x, function(y) {initialPheromone})})
lapply(terms, function(x) {sapply(x, function(y) {namedPheromone(y,initialPheromone)})})
#lapply(1:length(terms), function(i) {lapply(terms[[i]], function(y) {initialPheromone})})
}
namedPheromone<-function(term, pheromone) {
names(pheromone)<-term
return (pheromone)
}
build_rule <- function(trainingSet, terms, MinCasesPerRule, class, nr_of_class, entropies, pheromones) {
#liczba atrybutow
maxAttributes <- length(terms)
#budowana regula
#pusta na poczatku
rule <- character(maxAttributes)#NULL
#informacja o tym ktory atrybut zostal juz uzyty do stworzenia reguly
#vector sklada sie z tylu elementow ile jest atrybutow
#element moze przyjac 0 co oznacza ze atrybut zostal juz wykorzystany
#element moze przyjac 1 co oznacza ze atrybut nie zostal jeszcze wykorzystany
#posortowane od pierwszego atrybutu do ostatniego
#na poczatku zaden atrybut nie zostal wykorzystany (regula jest pusta)
rule.used_attributes <- rep(1, maxAttributes)
#vektor numerow atrybutow, aby wiedziec o kolejnosci atrybutow w regule
#rule.used_attributes nie powie nam ktory atrybut byl dodany kiedy tylko
#czy byl w ogole wykorzystany
rule.attributes <- numeric(maxAttributes)#NULL
isMinCasesPerRule<-TRUE
j<-1
while(sum(rule.used_attributes) > 0 & isMinCasesPerRule) {
etas <- computeEta(nr_of_class, entropies, rule.used_attributes);
probabilities <- computeProbabilities(etas, pheromones, rule.used_attributes);
#wylosowane termy na podstawie prawdopodobienstwa
unlistTerms <- unlist(removeUsedTerms(terms, rule.used_attributes))
size <- length(unlistTerms)
drawnTerms <- sample(unlistTerms, size, FALSE, unlist(removeUsedTerms(probabilities, rule.used_attributes)))
isMinCasesPerRule<-FALSE
for(i in 1:size) {
#wybierz z wylosowanych term'ow term ktory nie nalezy do
#atrybutow juz wybranych
attribute_id <- getAttributeId(terms, drawnTerms[i])
#sprawdzamy czy atrybut juz byl wykorzystany
#jestli tak to wybieramy kolejny term z listy wylosowanych term'ow
#if(rule.used_attributes[attribute_id] == 0) {
# next
#}
#tempRule<-append(rule, drawnTerms[i])
#tempRule.used_attributes<-rule.used_attributes
#tempRule.used_attributes[attribute_id]<-0
#tempRule.attributes <- append(rule.attributes, attribute_id)
#coveredCases<-coveredCases(tempRule, tempRule.attributes, trainingSet)
coveredCases<-coveredCases2(drawnTerms[i], attribute_id, trainingSet)
#jesli tymczasowa regula spelnia wymagania liczby pokrytych przypadkow
#to powiekszamy regule o wybrany term, przerywamy petle wybierania
#wylosowanych termow
if(nrow(coveredCases) >= MinCasesPerRule) {
rule[j]<-drawnTerms[i]#rule<-append(rule, drawnTerms[i])
rule.used_attributes[attribute_id]<-0
rule.attributes[j]<-attribute_id#rule.attributes <- append(rule.attributes, attribute_id)
isMinCasesPerRule<-TRUE
trainingSet<-coveredCases
j<-j+1
break
}
}
#moze sie zdarzyc ze po wyjsciu z petli for dodajacej termy
#nie zostanie dodany zaden term (bo nie spelni warunku pokrycia
#wystarczajacej liczby przypadkow)
}
# if(is.null(rule)){
# return (rule)
# }
#nie udalo sie dodac termu, za malo pokrytych przypadkow
if(j == 1) {
return (NULL)
}
rule[j]<-majorClass2(trainingSet, class)#rule<-append(rule, majorClass2(coveredCases, class))
rule<-rule[rule != ""]
rule.attributes[j]<-maxAttributes+1#rule.attributes<-append(rule.attributes, maxAttributes+1)
rule.attributes<-rule.attributes[rule.attributes != 0]
list(rule, rule.attributes)
}
build_rule2 <- function(trainingSet, terms, MinCasesPerRule, class, nr_of_class, entropies, pheromones) {
start.time <- Sys.time()
#liczba atrybutow
maxAttributes <- length(terms)
#budowana regula
#pusta na poczatku
rule <- NULL
#informacja o tym ktory atrybut zostal juz uzyty do stworzenia reguly
#vector sklada sie z tylu elementow ile jest atrybutow
#element moze przyjac 0 co oznacza ze atrybut zostal juz wykorzystany
#element moze przyjac 1 co oznacza ze atrybut nie zostal jeszcze wykorzystany
#posortowane od pierwszego atrybutu do ostatniego
#na poczatku zaden atrybut nie zostal wykorzystany (regula jest pusta)
rule.used_attributes <- rep(1, maxAttributes)
#vektor numerow atrybutow, aby wiedziec o kolejnosci atrybutow w regule
#rule.used_attributes nie powie nam ktory atrybut byl dodany kiedy tylko
#czy byl w ogole wykorzystany
rule.attributes <- NULL
#dodawaj term'y do reguly dopuki nie wykorzystasz wszystkich atrybutow
while(sum(rule.used_attributes) > 0) {
etas <- computeEta(nr_of_class, entropies, rule.used_attributes);
probabilities <- computeProbabilities(etas, pheromones, rule.used_attributes);
#wylosowane termy na podstawie prawdopodobienstwa
unlistTerms <- unlist(removeUsedTerms(terms, rule.used_attributes))
size <- length(unlistTerms)
drawnTerms <- sample(unlistTerms, size, FALSE, unlist(removeUsedTerms(probabilities, rule.used_attributes)))
#pokrycie wszystkich nowych regul
covers<-sapply(1:length(drawnTerms), function(i) {coveredCasesWithDrawnTerm(drawnTerms[i], terms, rule, rule.attributes, trainingSet)}, USE.NAMES = TRUE)
#ktore nowe reguly spelniaja warunek pokrycia
whichAreCovered<-ifelse(covers>=MinCasesPerRule, TRUE, FALSE)
#moze sie zdarzyc ze
#nie zostanie dodany zaden term (bo nie spelni warunku pokrycia
#wystarczajacej liczby przypadkow)
if(!is.element(TRUE, whichAreCovered)) {
break
}
firstCovered<-min(which(whichAreCovered==TRUE))
attribute_id<-as.integer(names(covers[firstCovered]))
rule<-append(rule, drawnTerms[firstCovered])
rule.used_attributes[attribute_id]<-0
rule.attributes <- append(rule.attributes, attribute_id)
}
if(is.null(rule)){
return (rule)
}
rule<-append(rule, majorClass(coveredCases(rule, rule.attributes, trainingSet), class, trainingSet))
rule.attributes<-append(rule.attributes, maxAttributes+1)
list(rule, rule.attributes)
}
coveredCasesWithDrawnTerm<-function(drawnTerm, terms, rule, rule.attributes, trainingSet) {
attribute_id <- getAttributeId(terms, drawnTerm)
rule<-append(rule, drawnTerm)
rule.attributes <- append(rule.attributes, attribute_id)
result<-length(coveredCases(rule, rule.attributes, trainingSet))
names(result)<-attribute_id
return (result)
}
removeUsedTerms<-function(terms, used_attributes) {
terms[which(used_attributes==0)]<-NULL
return (terms)
}
#oblicza znormalizowana entropie dla wszystkich term'ow
#eta wszystkich term'ow sumuje sie do 1
computeEta <- function(nr_of_class, entropies, used_attributes) {
lapply(entropies ,function(x) {sapply(x, function(entropy) {eta(nr_of_class, x, entropy, used_attributes)})})
}
#liczy znormalizowana entropie dla pary atrybut-wartosc (term)
#mianownik (dominator) tej funkcji jest staly dla wszystkich termow
#mozna by go liczyc tylko raz i podawac do funkcji???
eta <- function(nr_of_class, entropies, entropy, used_attributes) {
counter <- log2(nr_of_class)-entropy;
dominator <- sum(used_attributes)*sum((log2(nr_of_class)-unlist(entropies)))
counter/dominator;
}
#liczy prawdopodobienstwo wszystkich term'ow na podstawie
#znormalizowanych entropii i feromonu
computeProbabilities <- function(etas, pheromones, used_attributes) {
mapply(function(x, y) {mapply(function(eta, pheromone) {(eta*pheromone)/(sum(used_attributes)*sum(x*y))}, x, y)}, etas, pheromones)
}
#zwraca id atrybutu ktorego wartoscia jest dany term
getAttributeId <- function(terms, term) {
#min(which(sapply(terms, function(x) {is.element(term, x)}) == TRUE))
r<-sapply(terms, function(x) {sapply(x, function(y) {checkEqualTerm(term, y)})})
which(sapply(r, function(row) {is.element(TRUE, row)}) == TRUE)
}
#sprawdza czy termy ma taka sama wartosc i nazwe
checkEqualTerm<-function(term1, term2) {
term1 == term2 & names(term1) == names(term2)
}
#pokryte przez regule przypadki
#zwraca liste wierszy z pokrytymi przypadkami
coveredCases <- function(rule, rule.attributes, trainingSet) {
cases<-unlist(mapply(function(attribute, value) {which(trainingSet[attribute]==value)}, rule.attributes, rule))
table <- table(cases)
as.integer(names(table[table==length(rule)]))
}
coveredCases2 <- function(drawnTerm, attribute_id, trainingSet) {
trainingSet[which(trainingSet[attribute_id]==drawnTerm),]
}
#Zwraca klase dominujaca w pokrytych przypadkach
majorClass <- function(coveredCases, class, trainingSet) {
tt <- table(trainingSet[coveredCases, class])
major <- names(tt[tt==max(tt)])
return(major[1])
}
#zwraca klase domunujaca w danym zbiorze danych treningowych
majorClass2<-function(trainingSet, class) {
names(which.max(table(trainingSet[,class])))
}
#Przycina regule
prune <- function(rule, trainingSet, class) {
start.time<-Sys.time()
print("zaczynamy przycinac")
print(start.time)
isBetterQuality <- TRUE;
bestQuality <- quality(rule, trainingSet, class)
print("na poczatku najlepsza jakosc reguly")
print(start.time-Sys.time())
while( (length(rule[[2]]) > 2) & isBetterQuality) {
print("przed obliczeniem nowych jakosci")
print(start.time-Sys.time())
qualities<-sapply(1:(length(rule[[1]])-1), function(i) {quality(removeTerm(rule,i), trainingSet, class)})
print("po obliczeniu nowych jakosci")
print(start.time-Sys.time())
id<- which.max(qualities)
maxquality <- qualities[id]
if(maxquality > bestQuality) {
rule[[1]]<-rule[[1]][-id]
rule[[2]]<-rule[[2]][-id]
bestQuality <- maxquality
} else {
isBetterQuality <- FALSE;
}
print("czas potrzebny na usuniecie termu z reguly")
print(start.time-Sys.time())
}
rule[[1]][length(rule[[1]])]<-majorClass(coveredCases(rule[[1]], rule[[2]], trainingSet), class, trainingSet)
print("po sprawdzeniu major class")
print(start.time-Sys.time())
return (rule)
}
removeTerm<-function(rule, index) {
rule[[1]]<-rule[[1]][-index]
rule[[2]]<-rule[[2]][-index]
rule
}
#mierzy jakosc reguly
quality <- function(rule, trainingSet, class) {
n<-length(rule[[1]])
predictedClass<-rule[[1]][n]
coveredIndex<-Reduce(intersect, mapply(function(x,y) {which(trainingSet[y]==x)}, rule[[1]][-n], rule[[2]][-n]))
#pokryte przypadki przez regule
cases<-trainingSet[coveredIndex, ]
tp<-length(which(cases[, class]==predictedClass))
fp<-length(which(cases[, class]!=predictedClass))
#nie pokryte przypadki przez regule
cases<-trainingSet[-coveredIndex, ]
fn<-length(which(cases[, class]==predictedClass))
tn<-length(which(cases[, class]!=predictedClass))
quality <- (tp/(tp+fn))*(tn/(fp+tn))
#wzor na jakosc jest nie najlepszy bo mozna uzyskac dzielenie przez 0
#jak spada nam liczba przypadkow treningowych to moze sie zdarzyc
#ze choc jedna z powyzszych 4 wartosci bedzie 0
#w sumie to nie wiem co z tym robic, implementuje nie swoje zalozenia
#dziwne ze nie ujeli tego w artykule
#na razie jakosc ustawie na 0
#jakosc wplywa na zmiane feromonu wiec jest to dosc wazne
#Poprawka
#TP nie moze byc zero
#TN moze byc zero
#powinien byc tylko pierwszy czlon, drugi z TN do usuniecia w mojej wersji
#mysle tez ze nie da sie uzyskac na koniec innej klasy
#bo caly czas badamy jakosc reguly na podstawie klasy ktora wywnioskowalismy
#nie wybierzemy gorszej jakosci czyli reguly w ktorej inna klasa bedzie domuniujaca!!
if(is.nan(quality)) {
return(0)
}
return(quality)
}
quality2 <- function(rule, trainingSet, class) {
start.time<-Sys.time()
print("przed tp")
print(start.time-Sys.time())
TP<-length(TP(rule, trainingSet, class))
print("po tp")
print(start.time-Sys.time())
FP<-length(FP(rule, trainingSet, class))
print("po fp")
print(start.time-Sys.time())
FN<-length(FN(rule, trainingSet, class))
print("po fn")
print(start.time-Sys.time())
TN<-length(TN(rule, trainingSet, class))
print("po tn")
print(start.time-Sys.time())
quality <- (TP/(TP+FN))*(TN/(FP+TN))
print("po quality")
print(start.time-Sys.time())
#wzor na jakosc jest nie najlepszy bo mozna uzyskac dzielenie przez 0
#jak spada nam liczba przypadkow treningowych to moze sie zdarzyc
#ze choc jedna z powyzszych 4 wartosci bedzie 0
#w sumie to nie wiem co z tym robic, implementuje nie swoje zalozenia
#dziwne ze nie ujeli tego w artykule
#na razie jakosc ustawie na 0
#jakosc wplywa na zmiane feromonu wiec jest to dosc wazne
#Poprawka
#TP nie moze byc zero
#TN moze byc zero
#powinien byc tylko pierwszy czlon, drugi z TN do usuniecia w mojej wersji
#mysle tez ze nie da sie uzyskac na koniec innej klasy
#bo caly czas badamy jakosc reguly na podstawie klasy ktora wywnioskowalismy
#nie wybierzemy gorszej jakosci czyli reguly w ktorej inna klasa bedzie domuniujaca!!
if(is.nan(quality)) {
return(0)
}
print("po nan")
print(start.time-Sys.time())
return(quality)
}
TP <- function(rule, trainingSet, class) {
Reduce(intersect, mapply(function(x,y) {which(trainingSet[y]==x)}, rule[[1]], rule[[2]]))
}
FP <-function(rule, trainingSet, class) {
n<-length(rule[[1]])
result<-mapply(function(x,y) {which(trainingSet[y]==x)}, rule[[1]][-n], rule[[2]][-n], SIMPLIFY = FALSE)
result[[n]]<-which(trainingSet[rule[[2]][n]]!=rule[[1]][n])
Reduce(intersect, result)
}
FN <-function(rule, trainingSet, class) {
n<-length(rule[[1]])
result<-mapply(function(x,y) {which(trainingSet[y]!=x)}, rule[[1]][-n], rule[[2]][-n])
Reduce(intersect, list(unique(unlist(result)), which(trainingSet[rule[[2]][n]]==rule[[1]][n])))
}
TN <- function(rule, trainingSet, class) {
n<-length(rule[[1]])
result<-mapply(function(x,y) {which(trainingSet[y]!=x)}, rule[[1]][-n], rule[[2]][-n])
Reduce(intersect, list(unique(unlist(result)), which(trainingSet[rule[[2]][n]]!=rule[[1]][n])))
}
#True Positive
# TP <- function(rule, trainingSet, class) {
# for(i in 1:length(rule[[1]])) {
# trainingSet<-trainingSet[which(trainingSet[rule[[2]][i]]==rule[[1]][i]),]
# }
# return (trainingSet)
# }
#
# #False Positive
# FP <- function(rule, trainingSet, class) {
# n<-length(rule[[1]])
# for(i in 1:(n-1)) {
# trainingSet<-trainingSet[which(trainingSet[rule[[2]][i]]==rule[[1]][i]),]
# }
# trainingSet[which(trainingSet[rule[[2]][n]]!=rule[[1]][n]),]
# }
#
# #False Negative
# FN <- function(rule, trainingSet, class) {
# n<-length(rule[[1]])
# for(i in 1:(n-1)) {
# trainingSet<-trainingSet[which(trainingSet[rule[[2]][i]]!=rule[[1]][i]),]
# }
# trainingSet[which(trainingSet[rule[[2]][n]]==rule[[1]][n]),]
# }
#
# #True Negative
# TN<-function(rule, trainingSet, class) {
# for(i in 1:length(rule[[1]])) {
# trainingSet<-trainingSet[which(trainingSet[rule[[2]][i]]!=rule[[1]][i]),]
# }
# return (trainingSet)
# }
#zwieksza feromon dla term'ow ktore znalazly sie w regule
increasePheromone <- function(rule, pheromones, quality) {
n<-length(rule[[2]])
for(i in 1:(n-1)) {
attributeId<-rule[[2]][i]
term<-rule[[1]][i]
pheromones[[attributeId]][which(names(pheromones[[attributeId]])==term)]<-updated_pheromone(pheromones, attributeId, term, quality)
}
#mapply(function(term, attributeId) {pheromones[[attributeId]][which(names(pheromones[[attributeId]])==term)]=updated_pheromone(pheromones, attributeId, term, quality)}, rule[[1]][-n], rule[[2]][-n])
return (pheromones)
}
updated_pheromone<-function(pheromones, attributeId, term, quality) {
pheromone<-pheromones[[attributeId]][which(names(pheromones[[attributeId]])==term)]
pheromone+pheromone*quality
}
#zmiejsza feromon dla wszystkich term'ow
#symuluje wyparowywanie feromonu
decreasePheromone <- function(pheromones) {
n<-length(pheromones)
sum<-sum(sapply(pheromones, function(x) {sum(x)}))
lapply(pheromones, function(x) {sapply(x, function(pheromone){pheromone/sum})})
}
#sprawdza czy reguly sa takie same
isEqualRule <- function(rule1, rules) {
if(length(rules)==0) {
return (FALSE)
}
rule2<-rules[[length(rules)]]
#funkcja all sprawdza czy wszystkie wartosci sa TRUE, jestli tak to zwraca TRUE
all(mapply(function(term, attributeId) {is.element(term, rule2[[1]]) & is.element(attributeId, rule2[[2]])}, rule1[[1]], rule1[[2]]))
}
#przypadki ze zbioru ktorych regula nie pokrywa
#zastepuje dotychczasowy trainigSet eliminujac przypadki pokryte przez regule
uncoveredCases <- function(rule, trainingSet, class) {
trainingSet[-TP(rule, trainingSet, class), ]
}
#wnioskowanie klas danych na podstawie modelu
predict.antminer3 <- function(model, data) {
discoveredRules <- model[[1]]
defaultClass <- model[[2]]
test<-apply(data,1, function(x) {
result <- sapply(discoveredRules, function(y) {isCoveredByRule(y,x)})
coveredRules<-which(result == TRUE)
if(length(coveredRules)!=0) {
id<-coveredRules[1]
rule <- discoveredRules[[id]][[1]];
class <- tail(rule, 1)
x["class"]<-class
} else {
x["class"]<-defaultClass
}
return(x)
})
n<-ncol(data)
names <- names(data)
names<-append(names,"class")
df<-NULL;
for(i in 1:(n+1)) {
if(i == 1) {
df<-data.frame(test[seq(i,length(test),n+1)])
} else {
df[i]<-test[seq(i,length(test),n+1)]
}
}
names(df)<-names
return(df)
}
#sprawdza czy przypadek jest pokrywane przez regule
isCoveredByRule <- function(rule, case) {
al <- rule[[2]]
rule <- rule[[1]]
n<-length(rule)
for(i in 1:(n-1)) {
id<-al[i]
if(!(case[id] == rule[i])) {
return(FALSE)
}
}
return(TRUE)
}
Add the following code to your website.
For more information on customizing the embed code, read Embedding Snippets.