forked from jkrijthe/RSSL
-
Notifications
You must be signed in to change notification settings - Fork 0
Expand file tree
/
Copy pathEntropyRegularizedLogisticRegression.R
More file actions
104 lines (89 loc) · 3.71 KB
/
Copy pathEntropyRegularizedLogisticRegression.R
File metadata and controls
104 lines (89 loc) · 3.71 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
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
#' @include LogisticRegression.R
setClass("EntropyRegularizedLogisticRegression",
representation(w="numeric"),
prototype(name="Entropy Regularized Logistic Regression"),
contains="LogisticRegression")
#' Entropy Regularized Logistic Regression
#'
#' R Implementation of entropy regularized logistic regression implementation as proposed by Grandvalet & Bengio (2005). An extra term is added to the objective function of logistic regression that penalizes the entropy of the posterior measured on the unlabeled examples.
#'
#' @param lambda l2 Regularization
#' @param lambda_entropy Weight of the labeled observations compared to the unlabeled observations
#' @param init Initial parameters for the gradient descent
#' @inheritParams BaseClassifier
#' @references Grandvalet, Y. & Bengio, Y., 2005. Semi-supervised learning by entropy minimization. In L. K. Saul, Y. Weiss, & L. Bottou, eds. Advances in Neural Information Processing Systems 17. Cambridge, MA: MIT Press, pp. 529-536.
#' @return S4 object of class EntropyRegularizedLogisticRegression with the following slots:
#' \item{w}{weight vector}
#' \item{classnames}{the names of the classes}
#' @example inst/examples/example-EntropyRegularizedLogisticRegression.R
#' @export
EntropyRegularizedLogisticRegression <- function(X,y,X_u=NULL,lambda=0.0,lambda_entropy=1.0,intercept=TRUE, init=NA,scale=FALSE,x_center=FALSE) {
## Preprocessing to correct datastructures and scaling
ModelVariables<-PreProcessing(X=X,y=y,X_u=X_u,scale=scale,intercept=intercept,x_center=x_center)
X<-ModelVariables$X
X_u<-ModelVariables$X_u
y<-ModelVariables$y
scaling<-ModelVariables$scaling
classnames<-ModelVariables$classnames
modelform<-ModelVariables$modelform
m<-ncol(X)
if (is.na(init[1])) {
w <- rep(0.0,ncol(X)*(length(classnames)-1))
} else if (init=="supervised") {
w <- optim(w,
fn=loss_logisticregression,
gr=grad_logisticregression,
X=X, y=y, lambda=lambda,
classnames=classnames,
method="BFGS",
control=list(fnscale=-1))$par
} else {
w <- init
}
# Optimization
opt_result <- optim(w,
fn=loss_erlr,
gr=grad_erlr,
X, y, X_u,
lambda=lambda,
lambda_entropy=lambda_entropy,
classnames=classnames,
method="BFGS",
control = list(fnscale=-1))
w<-opt_result$par
new("EntropyRegularizedLogisticRegression",
modelform=modelform,
classnames=classnames,
w=w,
intercept=intercept,
opt_result=opt_result,
scaling=NULL)
}
loss_erlr <- function(w, X, y, X_u, classnames, lambda, lambda_entropy) {
loss_logisticregression(w,X,y,
classnames = classnames,
lambda=lambda) +
lambda_entropy * loss_entropy(w,X_u)
}
grad_erlr <- function(w, X, y, X_u, classnames, lambda, lambda_entropy) {
grad_logisticregression(w, X, y,
classnames = classnames,
lambda=lambda) +
lambda_entropy * grad_entropy(w,X_u)
}
loss_entropy <- function(w, X_u) {
w <- matrix(w,ncol(X_u))
inner <- cbind(rep(0,nrow(X_u)), X_u %*% w)
G <- exp(inner - as.numeric(logsumexp(inner)))
sum(G * log(G))
}
grad_entropy <- function(w, X_u) {
w <- matrix(w,ncol(X_u))
inner <- cbind(rep(0,nrow(X_u)), X_u %*% w)
G <- exp(inner - as.numeric(logsumexp(inner)))
G[G>1-1e-16] <- 1-1e-16
weight <- G*(1-G) * (log(G)-log(1-G))
weight <- weight[,2]
if(any(is.nan(weight))) stop("Numerical issues in gradient calculation.")
return(t(X_u) %*% weight)
}