Mixture modeling - troublee with infinite values from exp() and log() - r

I'm writing a function for Gaussian mixture models with spherical covariance structures--ie $\Sigma_k = \sigma_k^2 I$. This particular function is similar to the mclust package with identifier VII.
http://en.wikipedia.org/wiki/Mixture_model
Anyways, the problem I'm having is running into infinite values for the weight matrix. Definition: Let W be an n x m matrix where n = 1, ..., n (number of obs) and m = 1, ..., m (number of mixtues). Each element of W (ie w_ij) can essentially be defined as a specific form of:
w_im = \frac{a / b * exp(c)}{\sum_i=1^m [a_i / b_i * exp(c_i)]}
Computing this numerically is giving me infinite values. So I'm trying to use the log-identity log(x+y) = log(x) + log(1 + y/x). But the issue is that it's not as simple as log(x+y) but rather log(\sum_i=1^m [a_i / b_i * exp(c_i)]).
Here's some code define:
n_im = a / b * exp(c) ;
d_.m = \sum_i=1^m [a_i / b_i * exp(c_i)] ; and
c_mat[i,j] as the value of the exponent for the [i,j]th term.
n_mat[, i] <- log(a[i]) - log(b[i]) - c[,i] # numerator of w_im
internal_vec1[i] <- (a[i] * b[1])/ (a[1] * b[i]) # an internal for the step below
c_mat2 <- cbind(rep(1, n), c_mat[,1] - c_mat[,-1]) # since e^a / e^b = e^(a-b)
for (i in 1:n) {
d_vec[i] <- n_mat[i,1] + log(sum(internal_vec1 * exp(c_mat2[i,)))
} ## still getting infinite values
I'm trying to define the problem as briefly as possible. the entire function is obviously much larger than this. But, since the problem I'm running into is specifically dealing with infinite (and 1/infinity) values, I'm hoping this snippet is sufficient. Anyone with a coding trick here?

Here is the solution!! (I've spent way too damn long on this)
**The first function log_plus() solves the simple problem where you want log(\sum_{i=1)^n x_i)
**The second function log_plus2() solves the more complicated problem described above where you want log(\sum_{i=1}^n [a_i / b_i * exp(c_i)])
log_plus <- function(xvec) {
m <- length(xvec)
x <- log(xvec[1])
for (j in 2:m) {
sum_j <- sum(xvec[1:j-1])
x <- x + log(1 + xvec[j]/sum_j)
}
return(x)
}
log_plus2 <- function(a, b, c) {
# assumes intended input of form sum(a/b * e^c)
if ((length(a) != length(b)) || (length(a) != length(c))) {
stop("Input equal length vectors")
}
if (!(all(c > 0) || all(c < 0))) {
stop("All values of c must be either > 0 or < 0.")
}
m <- length(a)
# initilialize log sum
x <- log(a[1]) - log(b[1]) + c[1]
# aggregate / loop log sum
for (j in 2:m) {
# build denominator
b2 <- b[1:j-1]
for (i in 1:j-1) {
d1 <- 0
c2 <- c[1:i]
if (all(c2 > 0)) {
c_min <- min(c2[1:j-1])
c2 <- c2 - c_min
} else if (all(c2 < 0)) {
c_min <- max(c2[1:j-1])
c2 <- c2 - c_min
}
d1 <- d1 + a[i] * prod(b2[-i]) * exp(c2[i])
}
den <- b[j] * (d1)
num <- a[j] * prod(b[1:j-1]) * exp(c[j] - c_min)
x <- x + log(1 + num / den)
}
return(x)
}

Related

Unexpected symbol error when trying to run a function

Im trying to run the function below but I get:
Error: unexpected symbol in:
"MMod<-function (Pmat, cycle, n, Init, halfcycle=F, measure, discount=.03)
{cumul<-0 i"
MMod<-function (Pmat, cycle, n, Init, halfcycle=F, measure, discount=.03)
{cumul<-0 i<-1 istate<-Init m<-measure*cycle
if (halfcycle) {cumul<-0.5*(Init%*%m)} while (i <= n)
{ istate<-istate%*%Pmat imeasure<-istate%*%m cumul<-cumul+imeasure
#print(paste(c(i,round(istate,2),cumul))) i<-i+1
m<-m*(1-discount*cycle)
}
if (halfcycle) {cumul<-cumul - 0.5*imeasure} return(cumul)}
then I get more erros but I believe that is the key to run it.
R (among many programming languages) is very particular about this: different expressions must be separated either by a newline or a semi-colon. Try this:
MMod <- function(Pmat, cycle, n, Init, halfcycle = FALSE, measure, discount = 0.03) {
cumul <- 0
i <- 1
istate <- Init
m <- measure * cycle
if (halfcycle) {
cumul <- 0.5 * (Init %*% m)
}
while (i <= n) {
istate <- istate %*% Pmat
imeasure <- istate %*% m
cumul <- cumul + imeasure
#print(paste(c(i,round(istate,2),cumul))) i<-i+1
m <- m * (1 - discount * cycle)
}
if (halfcycle) {
cumul <- cumul - 0.5 * imeasure
}
return(cumul)
}

Newton-Raphson Root Finding Algorithm

Summary of problem
My objective is to create a function called newton.raphson to implement the Newton-Raphson root-finding algorithm.
Root Finding Algorithm: x1 = X0 - f(xo)/f'(x0)
I have 2 arguments:
iter = number of iteration (value = 10^5)
epsilon = for the tolerance (value = 10^-10)
Can not depend on variables outside of the function
newton.raphson <- function(f, x0, iter=1e5, epsilon=1e-10) {
x <- x0
h <- 1e-5
for (t in 1:iter) {
drvt <- f((x+h)) - f((x-h)) / (2 * h)
update <- x - f(x)/ drvt
if (abs(update) < epsilon) {
break
}
x <- update
}
root <- x
return(root)
}
# Define some function to test
f <- function(x) {
x^2 - 4 * x - 7
}
I get the following results:
> newton.raphson(f, 0)
[1] 2.000045
> newton.raphson(f, 3)
[1] 5.000024
But results should be:
-1.316625
5.316625
Your derivative calculation is a little bit broken - you forgot parenthesis around the difference between f(x+h) and f(x-h):
drvt <- ( f(x+h) - f(x-h) ) / (2 * h)
Also, you should compare the difference between the old and new root approximation to the tolerance. In order to make things more clear, rename your misleading update variable to something like new.x. Then, your should check if (abs(new.x - x) < epsilon).

NaN values while computing the probability in binomial distribution

I would like to compute integrate the following function
riskFunction <- function(theta, n, r, s)
{
risk <- 0
for (j in 1:n)
{
risk <- risk + abs(theta - r * j - s) * dbinom(j, n, theta)
}
return(risk)
}
using the trapeizodal method on the interval [0, 1]. That's my code
trapeizodalMethod <- function(a, b, m, n, r, s)
{
intValue <- 0
h <- (b - a)/m
for (i in 0:m-1)
{
intValue <- intValue + 0.5 * (riskFunction(a + i * h, n=n, r=r, s=s) + riskFunction(a + (i + 1) * h, n=n, r=r, s=s)) * h
}
return(intValue)
}
After calling trapezoidalMethod
trapeizodalMethod(a=0, b=1, m=100, n=100, r=0.01, s=0)
more than 50 errors occurs: In dbinom(j, 100, theta) : NaN produced.
I have no idea what might have gone wrong. I would appreciate any hints or tips.
That warning arises when dbinom(x, size, prob, log = FALSE) has prob outside [0, 1]. In your case, theta = -0.01 occurs because the loop is not running as you expected.
The binary operator : has higher precedence than binary -. So for example 1:5-1 is evaluated as (1:5) - 1, not 1:(5 - 1). You want
trapeizodalMethod <- function(a, b, m, n, r, s)
{
intValue <- 0
h <- (b - a)/m
for (i in 0:(m-1)) {
# ^^^^^
intValue <- intValue + 0.5 * (riskFunction(a + i * h, n=n, r=r, s=s) + riskFunction(a + (i + 1) * h, n=n, r=r, s=s)) * h
}
return(intValue)
}

How do I translate this maximization problem inside an equation to R?

fellow programmers. I'm studying a book on numerical solutions for economics (Judd 1998). I'm trying to reproduce a problem from that same book in R so I can use the optim package to see if I can get similar results.
The problem established by the author is this one: and his results were these.
I have tried to transcribe this problem to R, which resulted in this code chunk:
DisutilityJudd <- function(L){
if(L == 0){
return(0)
}else{
return(0.1)
}
}
AgentUtilityJudd <- function(w, L){
(-exp(-2*w) + 1) - DisutilityJudd(L)
}
reservation.utility.judd <- AgentUtilityJudd(1, 1)
MaxEffortUtility <- function(w1, w2, L = 1){
0.8 * AgentUtilityJudd(w1, L) + 0.2 * AgentUtilityJudd(w2, L)
}
LeastEffortUtility <- function(w1, w2, L = 0){
0.4 * AgentUtilityJudd(w1, L) + 0.6 * AgentUtilityJudd(w2, L)
}
UtilityDifferenceJudd <- function(w1, w2){
MaxEffortUtility(w1, w2) - LeastEffortUtility(w1, w2)
}
PenaltyFunctionJudd <- function(w1, w2, P = 100000){
if(length(w1) == 2){
y <- -1 * (0.8 * (2 - w1[1]) - 0.2 * w1[2] - P *
(pmax(0, -MaxEffortUtility(w1[1], w1[1]) - reservation.utility.judd))^2 -
P * (pmax(0, -UtilityDifferenceJudd(w1[1], w1[1])))^2)
}else{
y <- -1 * (0.8 * (2 - w1) - 0.2 * w2 - P *
(pmax(0, -MaxEffortUtility(w1, w2) - reservation.utility.judd))^2 -
P * (pmax(0, -UtilityDifferenceJudd(w1, w2)))^2)
}
return(y)
}
There were no errors, but the results generated by my code were nowhere near to what I was expecting:
optim(c(1.1, 0.5), PenaltyFunctionJudd)
$par
[1] 1.343909e+49 -2.370681e+51
$value
[1] -4.633849e+50
$counts
function gradient
501 NA
$convergence
[1] 1
$message
NULL
Perhaps there is a problem to my penalty function. I'm assuming that it is due to the pmax function. Could somebody help me identify it? Thank you, I appreciate your attention.
Edit: a typo.
I believe you meant w1[2] in when if(length(w1) == 2) is true.
I have modified your code, without touching how you define the previous function. It is not clear if it the result expected : what does IV(-1) mean, is it the result minus 1 ? a power if 10 ?
PenaltyFunctionJudd <- function(w1, w2, P = 1e5){
if(length(w1) > 1){
w2 <- w1[2]
w1 <- w1[1]
}
# cat("length is 2 \n")
y <- 0.8 * (2 - w1) - 0.2 * w2 - P *
( pmax(0, -MaxEffortUtility(w1, w2) - reservation.utility.judd) )^2 -
P * ( pmax(0, -UtilityDifferenceJudd(w1, w2)) )^2
# cat("pmax1 :", pmax(0, -MaxEffortUtility(w1, w2) - reservation.utility.judd), "\n")
# cat("pmax2 :", pmax(0, -UtilityDifferenceJudd(w1, w2)), "\n")
return(y)
}
optim(c(1.1, 0.5), PenaltyFunctionJudd, control = list(fnscale = -1) )
optim(c(11, 5), PenaltyFunctionJudd, method = "BFGS", control = list(fnscale = -1, maxit = 100) )
You can use cat or print to check your values (here I noticed some Inf and 0 the leaded me to notice code error).
Friendly warning : provided you defined correctly the previous function, there is lot of instability in optimisation (problem badly set ? More penalty needed ?). Indeed when running twice or more the algorithm parameters fluctuate a lot...

Applying a user defined R codes to a data set

I have R codes that I would like to apply to a data file. Please see the codes below:
library(plyr);
library(dplyr);
ability<- function(mdl, u, b, a, c){
J<- length(b)
if(mdl == 1 | mdl==2 | missing(c)) {
c<- rep(0,J)
}
if (mdl == 1 | missing(a)) { a<- rep(1,J)}
x<- sum(u)
if (x == 0) {
th<- -log(2*J)
}
if(x == J){
th<- log(2*J)
}
if (x == 0 | x == J) {
sumdem<- 0.0
for ( j in 1:J) {
pstar<- 1/(1 + exp(-a[j] * (th - b[j])))
phat<- c[j] + (1.0 - c[j])* pstar
sumdem<- sumdem - a[j]**2 * phat * (1.0 - phat) * (pstar / phat)**2
}
se <- 1/ sqrt(-sumdem)
}
if (x != 0 & x != J){
th<- log(x /(J-x))
S<- 10;
ccrit <- 0.001
for ( s in 1:S) {
sumnum <- 0.0
sumdem <- 0.0
for(j in 1:J){
pstar<- 1/(1 + exp(-a[j] * (th - b[j])))
phat<- c[j] + (1.0 - c[j])* pstar
sumnum<- sumnum + a[j] * (u[j] - phat) *
(pstar / phat)
sumdem <- sumdem - a[j]**2 * phat * (1.0 - phat) *
(pstar / phat)**2
}
delta<- sumnum / sumdem
th<- th - delta
if(abs(delta) < ccrit | s == S) {
se<- 1/sqrt(-sumdem)
break;
}
}
}
cat(paste("th=", th, "\n")); flush.console();
cat(paste("se=", se, "\n")); flush.console();
thse<- c(th, se);
return(thse);
}
u<-read.csv("C:\\PA\\Keystone\\Spring 018\\data\\out_sp16_ALGEBRA1.csv",header=TRUE,as.is=T);
b<- c(-0.5255,0.0645,-0.0685,0.4132,0.5103,0.6826,-0.524,-0.2108,-0.3115,0.583,-0.6093,1.1567,0.6096,-0.2789,0.1151,1.2127,-0.085,-0.2494,-0.2724,0.0433,-0.4693,0.1692,0.15,0.3255,0.6008,0.3654,-1.239,-0.7911,0.2886,0.2324,0.1885,0.6671,-0.1561,0.4412,1.4597,0.0981,0.2668,1.9483,2.0044,1.403,2.1106,1.0472);
a<- rep(1,length(b));
u<-u[,-c(1)]
u<-as.matrix(u)
apply()
The argument u is a data set that I converted to matrix and would like to apply the codes to all row of the matrix. a is a vector and b is a vector. I thought about using apply() but not giving me what I want.
Thanks for your time and input.
I am assuming that each row of the u represents different students and each column represents different items so using matrix indices may help(i.e sum(u[1,]) will compute sum for overall performance or all items combined for 1st student. also I did not get what you are asking specifically in order to guide what you should do.

Resources