Counting Values in R Vector - r

I have a large vector of percentages (0-100) and I am trying to count how many of them are in
specific 20% buckets (<20, 20-40, 40-60,60-80,80-100). The vector has length 129605 and there are no
NA values. Here's my code:
x<-c(0,0,0,0,0)
for(i in 1: length(mail_return))
{
if (mail_return[i]<=20)
{
x[1] = x[1] + 1
}
if (mail_return[i]>20 && mail_return[i]<=40)
{
x[2] = x[2] + 1
}
if (mail_return[i]>40 && mail_return[i]<=60)
{
x[3] = x[3] + 1
}
if (mail_return[i]>60 && mail_return[i]<=80)
{
x[4] = x[4] + 1
}
else
{
x[5] = x[5] + 1
}
}
But sum(x) is giving me length 133171. Shouldn't it be the length of the vector, 129605? What's wrong?


I like findInterval for these sorts of tasks:
x <- c(1,2,3,20,21,22,40,41,42,60,61,62,80,81,82)
table(findInterval(x,c(0,20,40,60,80)))
1 2 3 4 5
3 3 3 3 3


The reason for the bad count is that
x[5] effectively counts every occurrence which doesn't satisfy the condition mail_return[i]>60 && mail_return[i]<=80,
i.e. counting items that are > 80 (as you would expect), but also counting anew items that are <= 60 (outch! that the bug!).
You can replace...
if (mail_return[i]>60 && mail_return[i]<=80)
{
x[4] = x[4] + 1
}
else
{
x[5] = x[5] + 1
}
by...
if (mail_return[i]>60 && mail_return[i]<=80)
{
x[4] = x[4] + 1
}
if (mail_return[i] >80)
{
x[5] = x[5] + 1
}
...to fix things.
But as hinted in other answers, there are better idioms to find counts (such as table(findInterval(...)) ) which do not require such longhand code (and which are more efficient).

Related

What is wrong with my R for-loop that sums a series?

Here is my function that does a loop:
answer = function(a,n) {
for (k in 0:n) {
x =+ (a^k)/factorial(k)
}
return(x)
}
answer(1,2) should return 2.5 as it is the calculated value of
1^0 / 0! + 1^1 / 1! + 1^2 / 2! = 1 + 1 + 0.5 = 2.5
But I get
answer(1,2)
#[1] 0.5
Looks like it fails to accumulate all three terms and just stores the newest value every time. += does not work so I used =+ but it is still not right. Thanks.

answer = function(a,n) {
x <- 0 ## initialize the accumulator
for (k in 0:n) {
x <- x + (a^k)/factorial(k) ## note how to accumulate value in R
}
return(x)
}
answer(1, 2)
#[1] 2.5
There is "vectorized" solution:
answer = function(a,n) {
x <- a ^ (0:n) / factorial(0:n)
return(sum(x))
}
In this case you don't need to initialize anything. R will allocate memory behind that <- and sum.
You are using Taylor expansion to approximate exp(a). See this Q & A on the theme. You may want to pay special attention to the "numerical convergence" issue mentioned in my answer.

Create sequence in R

Hi I was wondering if someone knows how to realize this sequence in R?
Consider a sequence with following requirement.
a1=1
an=an-1+3 (If n is a even number)
an=2×an-1-5 (If n is a odd number)
e.g. 1,4,3,6,7,10,15,...
a30=?

Try the following.
It will return the entire sequence, not just the last element.
seq_chih_peng <- function(n){
a <- integer(n)
a[1] <- 1
for(i in seq_along(a)[-1]){
if(i %% 2 == 0){
a[i] <- a[i - 1] + 3
}else{
a[i] <- 2*a[i - 1] - 5
}
}
a
}
seq_chih_peng(30)
Note that I do not include code to check for input errors such as passing n = 0 or a negative number.

If you want to do it recursively, you just have the write the equations in your function as follows:
sequence <- function(n) {
if (n == 1) return(1)
else if (n > 1) {
if (n %% 2 == 1) {
return(2 * sequence(n - 1) - 5)
}else{
return(sequence(n - 1) + 3)
}
}else{
stop("n must be stricly positive")
}
}
sequence(30)
# returns 32770

Squeeze extreme ranges in a data.frame

I have a data.frame which contain 3 columns named start, end and width. Each line represent a segment over a 1D space with a start, and end and a width such as the "width = end - start + 1"
Here is an example
d = data.frame(
start = c(12, 50, 100, 130, 190),
end = c(16, 80, 102, 142, 201)
)
d$width = d$end - d$start + 1
print(d)
start end width
1 12 16 5
2 50 80 31
3 100 102 3
4 130 142 13
5 190 201 12
Consider two breakpoints and a factor of division
UpperPos = 112
LowerPos = 61
factor = 2
I would like to reduce the width of each segment outside the two breakpoints so that to reduce their width by a factor of factor. If a segment overlaps a breakpoint, then only the part of the segment that is outside this breakpoint should be reduced in width. In addition, the width of each segment must be a multiple of 3 and must be of non-zero length.
Here is my current function that "squeeze" the segments
squeeze = function(d, factor, LowerPos, UpperPos)
{
for (row in 1:nrow(d))
{
if (d[row,]$end <= LowerPos | d[row,]$end >= UpperPos) # Complete squeeze
{
middlePos = round(d[row,]$start + d[row,]$width/2)
d[row,]$width = round(d[row,]$width / factor)
d[row,]$width = d[row,]$width - d[row,]$width %% 3 + 3
d[row,]$start = round(middlePos - d[row,]$width/2)
d[row,]$end = d[row,]$start + d[row,]$width -1
} else if (d[row,]$start <= LowerPos & d[row,]$end >= LowerPos) # Partial squeeze (Lower)
{
d[row,]$start = round(LowerPos - (LowerPos - d[row,]$start)/factor)
d[row,]$width = d[row,]$end - d[row,]$start + 1
if (d[row,]$width %% 3 != 0)
{
add = 3 - d[row,]$width %% 3
d[row,]$width = d[row,]$width + add
d[row,]$start = d[row,]$start - add
}
} else if (d[row,]$start >= UpperPos & d[row,]$end <= UpperPos) # Partial squeeze (Upper)
{
d[row,]$end = round(UpperPos + (d[row,]$end - UpperPos)/factor)
d[row,]$width = d[row,]$end - d[row,]$start + 1
if (d[row,]$width %% 3 != 0)
{
add = 3 - d[row,]$width %% 3
d[row,]$width = d[row,]$width + add
d[row,]$end = d[row,]$start + add
}
} else if (!(d[row,]$end < UpperPos & d[row,]$start > LowerPos) )
{
print(d)
print(paste("row is ",row))
print(paste("LowerPos is ",LowerPos))
print(paste("UpperPos is ",UpperPos))
stop("In MyRanges_squeeze: Should not run this line!")
}
}
return(d)
}
and it returns the expected output
squeeze(d)
start end width
1 12 14 3
2 54 80 27
3 100 102 3
4 132 140 9
5 192 200 9
However, my function squeeze is way too slow. Can you help me to improve it?

Note that this answer only addresses how one may speed up your function, which is what you asked in your question, and not the validity of your logic with respect to your requirements.
As far as I can tell, all of your operations use vectorized operators. So, there is no need to loop over rows in squeeze. In the following, I have encapsulated all of your code that is within the if-else blocks as separate vectorized functions:
## This computes the case where d$end <= LowerPos | d$end >= UpperPos
f1 <- function(d, factor) {
middlePos = round(d$start + d$width/2)
d$width = round(d$width / factor)
d$width = d$width - d$width %% 3 + 3
d$start = round(middlePos - d$width/2)
d$end = d$start + d$width -1
d
}
## This is used below in f2
f4 <- function(d) {
add = 3 - d$width %% 3
d$width = d$width + add
d$start = d$start - add
d
}
## This computes the case where d$start <= LowerPos & d$end >= LowerPos
f2 <- function(d, factor, LowerPos) {
d$start = round(LowerPos - (LowerPos - d$start)/factor)
d$width = d$end - d$start + 1
ifelse(d$width %% 3 != 0, f4(d), d)
}
## This is used below in f3
f5 <- function(d) {
add = 3 - d$width %% 3
d$width = d$width + add
d$end = d$start + add
d
}
## This computes the case where d$start >= UpperPos & d$end <= UpperPos
f3 <- function(d, factor, UpperPos) {
d$end = round(UpperPos + (d$end - UpperPos)/factor)
d$width = d$end - d$start + 1
ifelse (d$width %% 3 != 0, f5(d), d)
}
Now, in squeeze, we use f1, f2, and f3 to compute the squeeze for all three cases separately. We also include the case for no squeeze as just d. We then rbind them to one big data frame, dd. Now, all we need is to pick the correct row from each block of rows (each of size nrow(d)) in dd based on the case for that row. For this, we compute a ind for the case (i.e., 1 to 4) using a series of ifelse's. The value of ind is the block to chose from, and its position is the row from that block to choose from. We use this to subset dd to get the output.
squeeze <- function(d, factor, LowerPos, UpperPos) {
d1 <- f1(d, factor)
d2 <- f2(d, factor, LowerPos)
d3 <- f3(d, factor, UpperPos)
dd <- do.call(rbind,list(d1,d2,d3,d))
ind <- ifelse(d$end <= LowerPos | d$end >= UpperPos, 1,
ifelse(d$start <= LowerPos & d$end >= LowerPos, 2,
ifelse(d$start >= UpperPos & d$end <= UpperPos, 3, 4)))
dd[(ind-1) * nrow(d) + 1:nrow(d),]
}
Using this version, the result is the same as yours:
out <- squeeze(d, factor, LowerPos, UpperPos)
## start end width
##1 12 14 3
##7 54 80 27
##18 100 102 3
##4 132 140 9
##5 192 200 9

R using "extract" Function: all cases discarded after aggregation

I'm trying to use the "extract" Function in R, which allows for Policy Mood analysis (documentation can be found here: http://www.unc.edu/~jstimson/Software_files/Doc.pdf). All of my cases are discarded, however, and I can't figure out whether the data or the function is the problem.
Here is a sample dataset with the code needed to execute the function (the "extract" function code is included further below):
library(car)
#create sample data frame
mat <- matrix(, nrow = 10, ncol = 0)
mat <- as.data.frame(mat)
mat$year <- c(1998,1999,2000,2001,2002,1996,1997,1998,2000,2002) #survey years
mat$varname <- c("ESS","ESS","ESS","ESS","ESS","ISSP","ISSP","ISSP","ISSP","ISSP") #survey names
mat$index <- c(10,20,30,20,30,10,20,30,20,10) #approval rating in survey
mat$ncases <- c(1000,1120,1300,800,1000,1200,1300,1400,1100,1000) #number of survey respondents
source("Extract.r") #loading Extract for estimating Mood
mat$date<-ISOdate(mat$year,1,1) #generate date variable
output<-extract(mat$varname,mat$date,mat$index,mat$ncases) #estimate mood series
The final line returns the following:
[1] "Series ESS discarded. After aggregation cases = 0"
[1] "Series ISSP discarded. After aggregation cases = 0"
Error in issue[, v] : subscript out of bounds
So the surveys are all being eliminated as unusable at aggregation. My best guess, looking at the function code below, is that the cases are being dropped for having uncomputable or zero standard deviations - but I don't understand why that would be the case.
Finally, here is the Extract.r code for the function. The code chunk I believe may be causing problems begins at "#NOW REDUCE ISSUE MATRIX TO ELIMINATE UNUSABLE SERIES (WN<2)":
display<-function(out,filename=NULL) {
if (is.null(filename)) filename=""
d<-out$dimensions
p<-out$period
m<-out$latent1
if (d==2) m2<-out$latent2
T<-out$T
mo=100*(p-as.integer(p))
for (t in 1:T) {
yr<-format(as.integer(p[t]),nsmall=0)
month<-format(mo[t],digits=2)
lat1<-format(m[t],nsmall=3)
if (d==1) {
cat(c(yr,month,lat1),fill=TRUE,file=filename,append=TRUE)
} else {
lat2<-format(m2[t],nsmall=3)
cat(c(yr,month,lat1,lat2),fill=TRUE,file=filename,append=TRUE)
}
}
}
##########################################################################################
plot.Zextract<-function(outobject) {
dim<- outobject$dimensions
T<- outobject$T
vect1<-outobject$latent1
t<-seq(1:T)
if (dim>1) {
vect2<-outobject$latent2
miny<-min(vect1)
if (miny>min(vect2)) miny<-min(vect2)
maxy<-max(vect1)
if (maxy<max(vect2)) maxy<-max(vect2)
dummy<-rep(miny,T-1) #dummy is a fake variable used to reset axes to handle min/max of both series
dummy[T]<-maxy
leg.text<-c("","Dimension 1","Dimension 2")
plot(t,dummy,type="l",lty=0,main="Final Estimation Results: Two Dimensions",xlab="Time Point",ylab="Latent Variables")
lines(t,vect1,col=1)
lines(t,vect2,col=2)
legend(1,maxy,leg.text,col=c(0,1,2),lty=c(0,1,1))
} else {
plot(t,vect1,type="l",main="Final Estimation Results",xlab="Time Point",ylab="Latent Variable")
if (dim == 2) lines(t,vect2,col=2)
}
}
##########################################################################################
summary.Zextract<- function(outobject) {
T=outobject$T
nvar=outobject$nvar
dim<- outobject$dimensions
vn<- c(outobject$varname,"Variable Name")
vn<- format(vn,justify="right")
nc<- format(outobject$N,justify="right")
ld<- format(outobject$loadings1,digits=3,justify="right")
mean<- format(outobject$means,digits=6,justify="right")
sd<- format(outobject$std.deviations,digits=6,justify="right")
cat("Variable Loadings and Descriptive Information: Dimension 1\n")
cat(paste(vn[nvar+1],"Cases","Loading"," Mean ","Std Dev","\n"))
for (v in 1:nvar) {
cat(paste(vn[v]," ",nc[v]," ",ld[v],mean[v],sd[v],"\n"))
}
if (dim == 2) {
ld<- format(outobject$loadings2,digits=3,justify="right")
cat("\nVariable Loadings and Descriptive Information: Dimension 2\n")
cat(paste(vn[nvar+1],"Cases","Loading"," Mean ","Std Dev","\n"))
for (v in 1:nvar) {
cat(paste(vn[v]," ",nc[v]," ",ld[v],mean[v],sd[v],"\n"))
}
}
}
##########################################################################################
findper<-function(unit,curdate,mind,miny,minper,aggratio) { #returns intFindPer
datcurdate<-curdate
class(datcurdate)<-"Date"
mo <- findmonth(datcurdate)
qu <- 1 + as.integer((mo - 1)/3)
dy <- findday(datcurdate)
yr <- findyear(datcurdate)
arinv<- 1/aggratio
if (unit == "D") intFindPer <- curdate - mind +1 #curdate - mindate + 1
if (unit == "A" || unit == "O") intFindPer <- as.integer((yr - miny) / aggratio) + 1
if (unit == "Q") part <- qu
if (unit == "M") part <- mo
if (unit == "Q" || unit == "M") intFindPer <- (yr - miny - 1) * arinv + part + (arinv - (minper - 1))
return(intFindPer)
} #findper
##########################################################################################
findday<-function(DateVar) {
z<-as.POSIXlt(DateVar)
v<-unlist(z)
findday<-as.integer(v[4])
} #end findday
##########################################################################################
findmonth<-function(DateVar) {
z<-as.POSIXlt(DateVar)
v<-unlist(z)
findmonth<-as.integer(v[5])+1
} #end findmonth
##########################################################################################
findyear<-function(DateVar) {
z<-as.POSIXlt(DateVar)
v<-unlist(z)
findyear<-as.integer(v[6])+1900
} #end findyear
##########################################################################################
aggregate<- function(varname,date,index,ncases,mindate,maxdate,nperiods,nvar,aggratio,unit,miny,minper) { #
#READ A NEW RECORD, CALCULATE PERIOD, AND SET UP AGGREGATION INTO MAT.ISSUE[NPERIODS,NVAR]
vl<- character(nvar)
mind<- as.integer(mindate)/86400
maxd<- as.integer(maxdate)/86400
vfac<- factor(varname) #make a factor vector
vlev<- levels(vfac) #find unique categories
Mat.Issue<- array(dim=c(nperiods,nvar))
nrec<-length(varname) #added for R compatibility
lp<- 0
per<- 0
x<- 0
c<- 0
nkeep<- 0
lv<- "0"
for (record in 1:nrec) { # MASTER LOOP THROUGH INPUT DATA, 1 TO NREC
if (ncases[record] == 0 || is.na(ncases[record])) ncases[record] <- 1000
mo <- findmonth(date[record])
qu <- 1 + as.integer((mo - 1)/3)
dy <- findday(date[record])
yr <- findyear(date[record])
curdate<- as.integer(date[record])
if (curdate >= mind && curdate <= maxd) { #is date within range?
nkeep <- nkeep + 1
if (nkeep==1) { #startup routine for first good case
firstcase<- TRUE
lp <- findper(unit,curdate,mind,miny,minper,aggratio)
lv <- varname[record]
x <- index[record] * ncases[record] #start new sums for case 1
c <- ncases[record]
for (i in 1:nvar) {
if (lv==vlev[i]) v=i #determine v by matching to position of labels vector
} #end for
} else {
firstcase<- FALSE
} #end if
if (firstcase == FALSE) { #skip over the rest for first good case
per<- findper(unit,curdate,mind,miny,minper,aggratio) #here we translate date into agg category
if ((varname[record] != lv) || (per !=lp)) { #found a new period or variable name
if (lp > 0 && lp <= nperiods) {
Mat.Issue[lp, v] <- x / c #recompute for either period or var change
x<- 0
c<- 0
}
if (varname[record] != lv) { #new var only
for (i in 1:nvar) {
if (varname[record]==vlev[i]) v=i #determine v by matching to position of labels vector
} #end for
vl[v]<- varname[record] #this will only catch names that have good cases
lv<-vl[v] #reassign new varname to lastvar
} # new var
lp <- findper(unit,curdate,mind,miny,minper,aggratio)
x <- index[record] * ncases[record] #start new sums for current case
c <- ncases[record]
} else {
x<- x + index[record] * ncases[record] #a continuing case, increment sums
c<- c + ncases[record]
}
} # end of first case special loop
} #end of date test loop
} #newrec: next record
vl<- vlev #overwrite previous assignment which had good names only
agglist<- list(lab=vl,iss=Mat.Issue)
return(agglist) #list includes labels and issue matrix
} #end aggregate function
##########################################################################################
esmooth<- function(mood, fb, alpha){
##########################################################################################
smooth<- function(alpha) { #for time series "series" and alpha "alpha[1]" compute sum of squared forecast error
ferror<- numeric(1)
T<- length(series)
xvect<- numeric(T)
xvect[1] <- series[1]
for (t in 2:T) {
xvect[t] <- alpha[1] * series[t] + (1 - alpha[1]) * xvect[t - 1]
}
sumsq <- 0
for (t in 3:T) {
ferror <- series[t] - xvect[t - 1]
sumsq <- sumsq + ferror ^ 2
}
return(sumsq) #this is the value of the function for a particular parameter alpha[1]
} # END OF FUNCTION SMOOTH
##########################################################################################
series<- mood[fb,] #create series to be smoothed
sm.out<- optim(c(.75),smooth,method="L-BFGS-B",lower=0.5,upper=1) #call smoother
alpha<- sm.out$par #assign result to alpha
#NOW SMOOTH USING ALPHA
T<- length(series)
for (t in 2:T) {
mood[fb,t] <- alpha * series[t] + (1 - alpha) * mood[fb,t - 1]
}
return(alpha)
} #END OF FUNCTION ESMOOTH
##########################################################################################
residmi<- function(issue,v,mood) { #function regresses issue(v) on mood and then residualizes it
o<- lm(issue[,v] ~ mood[3,]) #regress issue on mood to get a,b
issue[,v]<- 100 + issue[,v] - (o$coef[1]+o$coef[2]*mood[3,]) #100 + Y - (a+bx)
return(issue[,v])
}
##########################################################################################
iscorr<- function(issue,mood) { #compute issue-scale correlations
Nv<- length(issue[1,])
Np<- length(issue[,1])
Rvector<- numeric(Nv)
for (v in 1:Nv) {
N<- Np - sum(is.na(issue[,v]))
if (N > 1) Rvector[v]<- cor(issue[,v],mood[3,],use="complete.obs",method="pearson")
}
return(Rvector)
} #end function iscorr
##########################################################################################
dominate<- function(fb,issue,nperiods,nvar,mood,valid,smoothing,alpha) {
nitems<- numeric(nperiods)
if (fb==2) alpha1<-alpha
if (fb==1) {
unexp<-numeric(1)
everlap<- integer(1)
alpha<- 1
alpha1<- 1
}
if (fb == 1) {
startper <- 1
mood[fb, startper] <- 100
firstj <- 2
lastj <- nperiods
stepj <- 1
jprev <- 1
} else {
startper <- nperiods
mood[fb, startper] <- mood[1, nperiods] #reuse forward metric
firstj <- nperiods - 1
lastj <- 1
stepj <- -1
jprev <- nperiods
} # end if
for (j in seq(firstj,lastj,by=stepj)) {
mood[fb, j] <- 0
everlap <- 0 ## of years which have contributed sums to mood
if (fb == 1) {
firstj2 <- 1
lastj2 <- j - 1
} else {
firstj2 <- j + 1
lastj2 <- nperiods
} # end if
for (j2 in firstj2:lastj2) {
sum <- 0 #has already been estimated
consum <- 0 #sum of communalities across issues
overlap <- 0
for (v in 1:nvar) {
xj <- issue[j, v] #xj is base year value
sngx2 <- issue[j2, v] #sngx2 is comparison year value
if (!is.na(xj) && !is.na(sngx2)) {
overlap <- overlap + 1 #numb of issues contributing to sum
ratio <- xj / sngx2
if (csign[v] < 0) ratio <- 1 / ratio
sum <- sum + valid[v] * ratio * mood[fb, j2]
consum <- consum + valid[v]
} # end if
} #next v
if (overlap > 0) {
everlap <- everlap + 1
mood[fb, j] <- mood[fb, j] + sum / consum
} # end if
} #next j2
nitems[j] <- everlap
if (everlap > 0) mood[fb, j] <- mood[fb, j] / everlap else mood[fb, j] <- mood[fb, jprev] #if undefined, set to lag(mood)
jprev <- j #last value of j, whether lead or lag
} #next j
if (smoothing == TRUE) {
alpha<- esmooth(mood, fb, alpha) #NOW SMOOTH USING ALPHA
mood.sm<- mood[fb,] #set up alternate vector mood.sm
for (t in 2:nperiods) {
mood.sm[t]<- alpha*mood[fb,t]+(1-alpha)*mood.sm[t-1]
} #end for
mood[fb,]<- mood.sm #now assign back smoothed version
} else {
alpha1 <- 1
alpha <- 1
}
if (smoothing == TRUE && fb == 1) alpha1 <- alpha
dominate.out<- list(alpha1=alpha1,alpha=alpha,latent=mood[fb,]) #output object
return(dominate.out)
# return(mood[fb,])
} #end dominate algorithm
##########################################################################################
#begindt<-NA #ISOdate(2004,6,1)
#enddt<-NA #ISOdate(2004,10,31)
##########################################################################################
## MAIN EXTRACT CODE BEGINS HERE #########################################################
extract<- function(varname,date,index,ncases=NULL,unit="A",mult=1,begindt=NA,enddt=NA,npass=1,smoothing=TRUE,endmonth=12) {
formula<-match.call(extract)
nrecords<- length(varname)
if (is.null(ncases)) ncases<- rep(0,nrecords)
moddate<- date #create temporary date vector, leaving original unmodified
if ((unit=="A" || unit=="O") && endmonth<12) {
for (i in 1:nrecords) { #first loop through raw data file
month<- findmonth(moddate[i])
year<- findyear(moddate[i])
if (month>endmonth) moddate[i]<- ISOdate(year+1,1,1) #modified date become 1/1 of next year
} #end loop through data
} # end if
if (is.na(begindt)) minper<-findmonth(min(moddate)) else minper<-findmonth(begindt)
if (is.na(begindt)) miny<-findyear(min(moddate)) else miny<-findyear(begindt)
if (is.na(begindt)) minday<-findday(min(moddate)) else minday<-findday(begindt)
if (is.na(enddt)) maxper<-findmonth(max(moddate)) else maxper<-findmonth(enddt)
if (is.na(enddt)) maxy<-findyear(max(moddate)) else maxy<-findyear(enddt)
if (is.na(enddt)) maxday<-findday(max(moddate)) else maxday<-findday(enddt)
if (unit=="Q") {
minper<- as.integer((minper-1)/3)+1
maxper<- as.integer((maxper-1)/3)+1
}
mindate<- ISOdate(miny,minper,minday,0,0,0,tz="GMT")
maxdate<- ISOdate(maxy, maxper, maxday,0,0,0,tz="GMT") #86400=24*60*60
#SETCONS:
latent<- numeric(1)
aggratio<- 0
fb<- 1 #initialize
auto<- "start" #meaningless value
alpha<- 1
alpha1<- 1
pass<- 1
holdtola<- 0.001
tola<- holdtola
iter<- 0
lastconv<- 99999
wtmean<- 0 #for it=1
wtstd<- 1
fract<- 1
if (unit=="A") {
nperiods<- maxy-miny+1
aggratio<- 1
months<- 12
}
if (unit=="O") {
years<- mult
months<- years*12
aggratio<- 2
odd<- (maxy-miny+1) %% mult #mod
nperiods=as.integer((maxy-miny)/mult) + odd
}
if (unit=="M") {
fract<- 100
nperiods<- (maxy-miny)*12
nperiods<- nperiods-12 + (12-minper+1) + maxper
aggratio<- 1/12
months<- 1
}
if (unit=="Q") {
aggratio<- 1/4
months<- 3
nperiods<- as.integer((maxy-miny)/aggratio)
nperiods<- nperiods-4 + (4-minper+1) + maxper
fract<- 10
}
if (unit=="D") {
months=1
nperiods<- (as.integer(maxdate)-as.integer(mindate))/86400 + 1 #86400=24*60*60
}
arinv<- 1/aggratio
aggratio<- months/12
nrecords<- length(index)
#HERE WE SET UP FUNDAMENTAL DIMENSIONS AND DECLARE VECTORS
if (fb != 2) mood<- array(dim=c(3,nperiods))
vfac<- factor(varname) #make a factor vector
vlev<- levels(vfac) #find unique categories
nvar<- length(vlev) #how many are there?, includes unusable series
valid<- numeric(nvar)
csign<<- numeric(nvar)
vl<- character(nvar)
r<- numeric(nvar)
oldr<- rep(1,nvar) # r=1 for all v initially
issue<- array(dim=c(nperiods,nvar))
count<- numeric(nperiods)
vl<- numeric(nvar)
period<- numeric(nperiods)
converge<- 0
evalue<- 0
# create numeric variable period, eg, yyyy.0m
if (unit=="D") {
period<-seq(1:nperiods)
} else {
if (months >= 12) {
for (l in 1:nperiods) {
p <- (l - 1) * aggratio
period[l] <- miny + p
} #next l
} else {
y <- 0
i <- 0
my <- miny
if (minper == 1) my <- my - 1
for (l in 1:nperiods) {
i<- 1 + ((l-1) %% arinv)
mq <- minper + i - 1
mq<- 1 + ((mq-1) %% arinv)
if (mq == 1) y <- y + 1 #first month or quarter, increment year
period[l] <- my + y + mq / fract
} # end for
} #end else
} # end if
agglist<- aggregate(varname,moddate,index,ncases,mindate,maxdate,nperiods,nvar,aggratio,unit,miny,minper) # call aggregate to produce issue matrix
vl<- agglist$lab #extract two elements of the list from aggregate call
issue<- agglist$iss
rm(agglist) #don't need this anymore
#NOW REDUCE ISSUE MATRIX TO ELIMINATE UNUSABLE SERIES (WN<2)
ndrop<- 0
nissue<- numeric(nperiods)
std<- numeric(nperiods)
for (v in 1:nvar) {
std[v]<- 0 #default
nissue[v]<- sum(!is.na(issue[,v])) #criterion is 2 cases for npass=1 or 3 for npass=2
if (nissue[v]>npass) std[v]<- sqrt(var(issue[,v],na.rm=TRUE)) #this is just a test for variance >0
if (std[v]<.001) { #case dropped if std uncomputable (NA) or actually zero (constant)
ndrop<- ndrop+1
print(paste("Series",vl[v],"discarded. After aggregation cases =",nissue[v]))
}
}
nvarold<- nvar
nvar<- nvar-ndrop
pointer<- 1
found<- FALSE
for (v in 1:nvar) { #now reduced nvar
while (found==FALSE && pointer<=nvarold) { #find first valid column and push down
if (std[pointer]>.001) { #good case, transfer
issue[,v]<- issue[,pointer]
vl[v]<- vl[pointer]
pointer<- pointer+1
found<- TRUE
} else {
pointer<- pointer+1 #bad case, increment pointer
} #end if
} #end while
found<- FALSE
} #for
length(vl)<- nvar #reduce
length(issue)<- nperiods*nvar #chop off unused columns
attr(issue,"dim")<- c(nperiods,nvar)
N<- numeric(nvar)
#export<<-list(nperiods,nvar,issue)
for (pass in 1:npass) { #newpass: RESTART FOR SECOND DIMENSION CASE
if (pass == 2) { #reset iteration control parameters
iter <- 0
tola = holdtola
lastconv <- 99999
converge<- lastconv
conv<- converge
} else {
av<- numeric(nvar)
std<- numeric(nvar)
# ngood<- 0
for (v in 1:nvar) { #compute av and std by issue nvar now reduced to good cases
wn<- as.integer(nperiods-sum(is.na(issue[,v])))
av[v] <- mean(issue[,v],na.rm=TRUE)
std[v]<- sqrt(var(issue[,v],na.rm=TRUE) * ((wn - 1)/wn)) #convert to population standard deviation
issue[,v]<- 100 + 10 * (issue[,v] - av[v])/std[v] #standardize
# ngood<- ngood+1
}#end for
}
#READY FOR ESTIMATION, SET UP AND PRINT OPTIONS INFO
out<- as.character(10) #initial length only
out[1]<- print(paste("Estimation report:"))
if (pass == 1) {
if (months >= 12) {
out[2]<- print(paste("Period:", miny, " to", maxy," ", nperiods, " time points"))
} else {
out[2]<- print(paste("Period:", miny, minper, " to", maxy, maxper, nperiods, " time points"))
}
out[3]<- print(paste("Number of series: ", nvar+ndrop))
out[4]<- print(paste("Number of usable series: ", nvar))
out[5]<- print(paste("Exponential smoothing: ",smoothing))
}
out[6]<- print(paste("Iteration history: Dimension ",pass))
print(" ")
out[7]<- print("Iter Convergence Criterion Reliability Alphaf Alphab")
outcount<- 7
for (p in 1:nperiods) {
count[p]<- sum(!is.na(issue[p,]))
}
valid<- rep(1,times=nvar)
csign<<- rep(1,times=nvar)
auto <- "y" #iterative estimation on by default
quit <- 0 #false implies go ahead and estimate
while (iter == 0 || converge > tola) { #MASTER CONTROL LOOP WHICH ITERATES UNTIL SOLUTION REACHED
for (fb in 1:2) { # MASTER fb LOOP fb=1 is forward, 2 backward
dominate.out<- dominate(fb,issue,nperiods,nvar,mood,valid,smoothing,alpha) #master estimation routine
alpha1<- dominate.out$alpha1
alpha<- dominate.out$alpha
mood[fb,]<- dominate.out$latent
} #next fb
fb <- 3 #average mood from here on
for (p in 1:nperiods) { # AVERAGE
mood[fb, p] <- (mood[1, p] + mood[2, p]) / 2
} #next p
moodmean<-mean(mood[3,])
sdmood<-sd(mood[3,])
for (p in 1:nperiods) { #PLACEMENT OF THIS LOOP MAY NOT BE RIGHT
mood[fb,p] <- ((mood[fb,p] - moodmean) * wtstd / sdmood) + wtmean
} #end for
#plot commands
t<- seq(1:nperiods) #time counter used for plot below
lo<- 50 #force scale of iterative plot to large range
hi<- 150
if (min(mood[3,]) < lo) lo=min(mood[3,]) #whichever larger, use
if (max(mood[3,]) > hi) hi=max(mood[3,])
dummy<- rep(lo,nperiods) #dummy is fake variable used to set plot y axis to 50,150
dummy[nperiods]<- hi
if (iter==0) {
plot(t,dummy,type="l",lty=0,xlab="Time Period",ylab="Estimate by iteration",main="Estimated Latent Dimension") #create box, no visible lines
} else {
lines(t,mood[3,],col=iter)
}
iter <- iter + 1
if (auto == "y") r<- iscorr(issue,mood) else auto <- "y" #recompute correlations
wtmean<- 0
wtstd<- 0
vsum<- 0
goodvar<- 0
converge<- 0 #start off default
evalue<- 0
totalvar<- 0
for (v in 1:nvar) {
wn<- nperiods-sum(is.na(issue[,v]))
if (!is.na(sign(r[v]))) csign[v]<<- sign(r[v])
wn<- nperiods-sum(is.na(issue[,v]))
if (wn>1) { #sum over variables actually used
vratio <- wn / nperiods
evalue <- evalue + vratio * r[v]^2
totalvar <- totalvar + vratio
} #end if
#convergence tests
if (wn > 3) {
conv <- abs(r[v] - oldr[v]) #conv is convergence test for item=v
conv <- conv * (wn / nperiods) #weight criterion by number of available periods
if (conv > converge) converge <- conv #converge is the global max of conv
} #end if
if (!is.na(r[v])) oldr[v] <- r[v]
if (!is.na(r[v])) valid[v] <- r[v]^2
if (!is.na(av[v])) wtmean <- wtmean + av[v] * valid[v]
if (!is.na(std[v])) wtstd <- wtstd + std[v] * valid[v]
if (!is.na(r[v])) vsum <- vsum + valid[v]
} #end v loop
if (vsum > 0) wtmean <- wtmean / vsum
if (vsum > 0) wtstd <- wtstd / vsum
if (pass == 1) {
mean1 <- wtmean
std1 <- wtstd
e1=evalue
} else {
wtmean <- mean1
wtstd <- std1 #*unexp
} #end if
fbcorr <- cor(mood[1,],mood[2,]) #fnfrontback
if (quit != 1) {
outcount<- outcount+1
cv<- format(round(converge,4),nsmall=4)
itfmt<-format(round(iter),justify="right",length=4)
out[outcount]<- print(paste(itfmt," ",cv," ",round(tola,4)," ",round(fbcorr,3),round(alpha1,4),round(alpha,4)))
}
if (converge > lastconv) tola <- tola * 2
lastconv <- converge
auto = "y" #skip corr on iter=1, set auto on
if (iter >= 50) break #get out of while loop
} #END MASTER WHILE ITERATION CONTROL LOOP
if (auto == "y" && converge<tola) { #IF WE REACH THIS CODE WE HAVE A FINAL SOLUTION TO BE REPORTED
if (pass == 1) out1<- out #hold output for 2 dimensional solution
auto <- "Q"
quit <- 1 #flag solution reached, last time through
r<- iscorr(issue,mood) #final iteration correlations
if (pass == 1) r1<- r #hold correlations for 2 dimensional solution
if (pass > 1) {
unexp <- totalvar
totalvar <- unexp * totalvar
evalue <- evalue * unexp
} # end if
if (pass == 1) {
expprop <- evalue / totalvar
tot1 <- totalvar
} else {
erel <- evalue / totalvar #% exp relative
totalvar <- (1 - expprop) * tot1 #true var=original var discounted by %exp
evalue <- erel * totalvar #rescale to retain %exp relationship
expprop <- evalue / tot1 #now reduce eral to expprop
} # end if
for (v in 1:nvar) {
N[v]<- sum(!is.na(issue[,v]))
}
var.out<- list(varname=vl,loadings=r,means=av,std.deviations=std)
print(" ")
outcount<- outcount+1
out[outcount]<- print(paste("Eigen Estimate ", round(evalue,2), " of possible ",round(tot1,2)))
outcount<- outcount+1
out[outcount]<- print(paste(" Percent Variance Explained: ",round(100 * expprop,2)))
if (pass != 2 && npass>1) {
for (v in 1:nvar) {
valid[v] <- 0 #reset all, regmoodissue will set good=1
if (csign[v] != 0) issue[,v]<- residmi(issue,v,mood) #regmoodissue()
} #v loop
} # if
#begin prn output routine # mood[fb,] is now our estimate, WHAT ABOUT A SECOND DIMENSION
latent<- mood[fb,] #vector holds values for output
if (pass == 1) latent1<- latent #hold first dimension
print(" ")
out[outcount+1]<- print(paste("Final Weighted Average Metric: Mean: ",round(wtmean,2)," St. Dev: ",round(wtstd,2)))
#for Zelig output
if (npass==1) {
extract.out<- list(formula=formula,T=nperiods,nvar=nvar,unit=unit,dimensions=npass,period=period,varname=vl,N=N,means=av,std.deviations=std,setup1=out1,loadings1=r1,latent1=latent1)
} else {
for (i in 6:outcount) {
out[i-5]=out[i]
}
length(out)<- outcount-5
extract.out<- list(formula=formula,T=nperiods,nvar=nvar,unit=unit,dimensions=npass,period=period,varname=vl,N=N,means=av,std.deviations=std,setup1=out1,loadings1=r1,latent1=latent1,setup2=out,loadings2=r,latent2=latent)
}
} #end if auto="y"
} #end of for pass=1,2 loop
par(col=1) #reset on termination
class(extract.out)<- "Zextract"
return(extract.out)
} #end of extract
Anyone have any ideas what's going wrong here? Thanks in advance for your time!

The issue here seems to be dates inside the aggregate function (note, not the base R aggregate). Namely, a minimum and maximum date are calculated as:
mind<- as.integer(mindate)/86400
maxd<- as.integer(maxdate)/86400
These are then compared (inside a loop for each date) against the curdate variable, using an if statement:
if (curdate >= mind && curdate <= maxd) { #is date within range?
The problem, though, is that curdate<- as.integer(date[record]) (the line immediately before the if statement) is not on the same time scale. Changing it to: curdate<- as.integer(date[record])/86400 seems to solve the problem.

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

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)
}

Resources