forked from jkrijthe/RSSL
-
Notifications
You must be signed in to change notification settings - Fork 0
Expand file tree
/
Copy pathEMNearestMeanClassifier.R
More file actions
65 lines (57 loc) · 3.07 KB
/
Copy pathEMNearestMeanClassifier.R
File metadata and controls
65 lines (57 loc) · 3.07 KB
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
#' @include NearestMeanClassifier.R
setClass("EMNearestMeanClassifier",
representation(responsibilities="matrix", iterations="numeric"),
prototype(name="Expectation Maximization Nearest Mean Classifier"),
contains="NearestMeanClassifier")
#' Semi-Supervised Nearest Mean Classifier using Expectation Maximization
#'
#' Expectation Maximization applied to the nearest mean classifier assuming Gaussian classes with a spherical covariance matrix.
#'
#' Starting from the supervised solution, uses the Expectation Maximization algorithm (see Dempster et al. (1977)) to iteratively update the means and shared covariance of the classes (Maximization step) and updates the responsibilities for the unlabeled objects (Expectation step).
#'
#' @references Dempster, A., Laird, N. & Rubin, D., 1977. Maximum likelihood from incomplete data via the EM algorithm. Journal of the Royal Statistical Society. Series B, 39(1), pp.1-38.
#'
#' @param method character; Currently only "EM"
#' @param scale Should the features be normalized? (default: FALSE)
#' @param eps Stopping criterion for the maximinimization
#' @inheritParams BaseClassifier
#'
#' @export
EMNearestMeanClassifier <- function(X, y, X_u, method="EM",scale=FALSE, eps=1e-4) {
## Preprocessing to correct datastructures and scaling
ModelVariables<-PreProcessing(X=X,y=y,X_u=X_u,scale=scale,intercept=FALSE)
X<-ModelVariables$X
X_u<-ModelVariables$X_u
y<-ModelVariables$y
scaling<-ModelVariables$scaling
classnames<-ModelVariables$classnames
modelform<-ModelVariables$modelform
Y <- model.matrix(~as.factor(y)-1)
Xe<-rbind(X,X_u)
if (method=="EM") {
responsibilities_old <- matrix(0,nrow(X_u),length(classnames)) # Set all posteriors to 0
responsibilities <- posterior(NearestMeanClassifier(X,y),X_u) # Set posterior on the unlabeled objects based an classifier estimated on labeled objects
iteration <- 0
while (max(abs(responsibilities-responsibilities_old)) > eps) {
iteration <- iteration+1
if (iteration>100) { break }
prior <- matrix(colMeans(rbind(Y,responsibilities)),2,1)
means <- t((t(Xe) %*% rbind(Y,responsibilities)))/(colSums(rbind(Y,responsibilities)))
Ye <- rbind(Y,responsibilities)
sigma <- (sum(Ye[,1] * (Xe-(matrix(1,nrow(Xe),1) %*% means[1,,drop=FALSE]))^2)+sum(Ye[,2] * (Xe-(matrix(1,nrow(Xe),1) %*%means[2,,drop=FALSE]))^2))/(nrow(Xe)*ncol(Xe))
sigma <- diag(ncol(X))*sigma
sigma <- lapply(1:ncol(Y),function(c){sigma})
g_iteration <- new("NearestMeanClassifier", modelform=NULL, means=means, prior=prior, sigma=sigma,classnames=classnames,scaling=scaling)
# print(losspart(g_iteration,Xe,Ye))
responsibilities_old <- responsibilities
responsibilities <- posterior(g_iteration,X_u)
Ye <- rbind(Y,responsibilities)
# print(losspart(g_iteration,Xe,Ye))
}
}
new("EMNearestMeanClassifier",
modelform=modelform, classnames=classnames,
means=means, prior=prior, sigma=sigma,
scaling=scaling,
responsibilities=responsibilities,iterations=iteration)
}