# R/old.metropolis.R In tripEstimation: Metropolis sampler and supporting functions for estimating animal movement from archival tags and satellite fixes

```"mkElevationSeg" <-
function(segments,day) {
## day - times as POSIXct
## segments - indexs separate segments of light curve

## Extract components of time (GMT)
tm <- as.POSIXlt(day,tz="GMT")
hh <- tm\$hour
mm <- tm\$min
ss <- tm\$sec

## Time as Julian day
jday <- julday(tm)+(hh+(mm+ss/60)/60)/24

## Time as Julian century
t <- (jday-2451545)/36525

## Geometric mean anomaly for the sun (degrees)
M <- 357.52911+t*(35999.05029-0.0001537*t)

## Equation of centre for the sun (degrees)
eqcent <- sin(pi/180*M)*(1.914602-t*(0.004817+0.000014*t))+
sin(pi/180*2*M)*(0.019993-0.000101*t)+
sin(pi/180*3*M)*0.000289

## The geometric mean sun longitude (degrees)
L0 <- 280.46646+t*(36000.76983+0.0003032*t)
## Limit to [0,360)
L0 <- L0%%360

## The true longitude of the sun (degrees)
lambda0 <- L0 + eqcent

## The apparent longitude of the sun (degrees)
omega <- 125.04-1934.136*t
lambda <- lambda0-0.00569-0.00478*sin(pi/180*omega)

## The mean obliquity of the ecliptic (degrees)
seconds <- 21.448-t*(46.815+t*(0.00059-t*(0.001813)))
obliq0 <- 23+(26+(seconds/60))/60

## The corrected obliquity of the ecliptic (degrees)
omega <- 125.04-1934.136*t
obliq <- obliq0 + 0.00256*cos(pi/180*omega)

## The eccentricity of earth's orbit
e <- 0.016708634-t*(0.000042037+0.0000001267*t)

## The equation of time (minutes of time)
y <- tan(pi/180*obliq/2)^2
eqtime <- 180/pi*4*(y*sin(pi/180*2*L0) -
2*e*sin(pi/180*M) +
4*e*y*sin(pi/180*M)*cos(pi/180*2*L0) -
0.5*y^2*sin(pi/180*4*L0) -
1.25*e^2*sin(pi/180*2*M))

solarDec <- asin(sin(pi/180*obliq)*sin(pi/180*lambda))
sinSolarDec <- sin(solarDec)
cosSolarDec <- cos(solarDec)

## ALT
## sinSolarDec <- sin(pi/180*obliq)*sin(pi/180*lambda)
## cosSolarDec <- cos(asin(sinSolarDec))

## Solar time unadjusted for longitude (degrees)
solarTime <- (hh*60+mm+ss/60+eqtime)/4

## Split by segment
solarTime <- split(solarTime,segments)
sinSolarDec <- split(sinSolarDec,segments)
cosSolarDec <- split(cosSolarDec,segments)

function(segment,lon, lat) {

## Suns hour angle (degrees)
## change subtraction to addition to work with -180<->180 convention MDS2Jul03

hourAngle <- solarTime[[segment]]+lon-180

## Cosine of sun's zenith
cosZenith <- sin(pi/180*lat)*sinSolarDec[[segment]]+
cos(pi/180*lat)*cosSolarDec[[segment]]*cos(pi/180*hourAngle)

## Limit to [-1,1]
cosZenith[cosZenith > 1] <- 1
cosZenith[cosZenith < -1] <- -1

## Ignore refraction correction
90-180/pi*acos(cosZenith)
}
}

"mkNLPosterior" <-
function(segments,day,light,calib) {

segments <- unclass(factor(segments))

## Construct elevation function
elevation <- mkElevationSeg(segments,day)

## Split light levels by segments
light <- split(light,segments)

## We return a function that computes the negative log posterior
function(seg,ps,prv,nxt) {
## seg - the segment of the light curve
## ps - params for this segment
## prv,nxt - params for previous and next segments

## Decompose params into (lat, lon) and offset
#lat <- ps[1]
#lon <- ps[2]
lon <- ps[1]
lat <- ps[2]
k <- ps[3]

##-  Problem sometimes with elevation - "trying to subscript too many elements"
##- (might be the split)
## Compute elevations for this (lat, lon) and segment
elev <- elevation(seg, lon, lat)

## The expected light levels
lgt <- calib(elev)

## The log likelihood.
sigma <- 7
shape <- (70/30)^2
rate <- (70/30^2)*10
eps <- 1.0E-6
loglik <- sum(dnorm(light[[seg]], k+lgt, 7, log=TRUE),
## Must not allow zero distances for gamma pdf.
dgamma(max(eps, old.dist.gc(prv[1:2],ps[1:2])), shape, rate,log=TRUE),
dgamma(max(eps, old.dist.gc(ps[1:2],nxt[1:2])), shape, rate,log=TRUE))

## Return negative log posterior
-(log(k.prior(seg, ps))+loglik)
}
}

"old.dist.gc" <-
function (x1, x2 = NULL)
{
if (is.null(x2)) {
if (!is.matrix(x1) && !is.data.frame(x1)) stop("No points to calculate")
pt1 <- x1[-1,]
pt2 <- x1[-nrow(x1),]
x1 <- pt1
x2 <- pt2
}
pt1 <-  matrix(as.vector(as.matrix(x1)), ncol = 2)
pt2 <-  matrix(as.vector(as.matrix(x2)), ncol = 2)
a <- cos(pi/180 * pt1[, 2]) * cos(pi/180 * pt2[,
2]) * cos(pi/180 * (pt2[, 1] - pt1[, 1])) + sin(pi/180 *
pt1[, 2]) * sin(pi/180 * pt2[, 2])

6378.137 * acos(pmin(a,1))
}

"old.find.init" <-
function (mask, nseg, nlpost, pars = c("Lon", "Lat", "k"))
{
inits <- matrix(0, nseg, length(pars), dimnames = list(NULL,
pars))
xx <- xx[-1] - diff(xx[1:2])/2
yy <- yy[-1] - diff(xx[1:2])/2
}
xy <- as.matrix(expand.grid(x = xx, y = yy))
print(paste("k of", nseg))
for (k in 1:nrow(inits)) {

p <- c(pts[1, 1:2], 0)
nlp.mode <- nlpost(k, p, p, p)
p.mode <- p
for (i in 2:nrow(pts)) {
p <- c(pts[i, ], 0)
nlp <- nlpost(k, p, p, p)
if (nlp < nlp.mode) {
nlp.mode <- nlp
p.mode <- p
}
}
cat(k, "\n")
inits[k, ] <- p.mode
}
inits
}

"old.metropolis" <-
function(nlpost,lookup,p0,cov0,start,end, iter=1000,step=100) {
# nlpost<-nlogpost;p0<-ps;cov0<-cov.ps;mat<-summ;iter=20;step=10
## Initialize chain - internally we always work with transpose p.
p <- t(p0)

## m parameters per twilight and n twilights
m <- nrow(p)
n <- ncol(p)

## Precalculate the Cholesky decomposition the covariance of the
## proposal distribution for each block.
U <- cov0
for(j in 1:n) U[,,j] <- chol(U[,,j],pivot = TRUE)## I think you need pivot for 1.7.0

## Record chain as a matrix
chain.p <- matrix(0,iter,m*n)
colnames(chain.p) <- paste(colnames(p0),rep(1:n,each=m),sep="")

## Posterior for each block at initial locations
l <- rep(0.0, n)
l[1] <- nlpost(1, p[,1], start, p[,2])
for(j in 2:(n-1)) {
l[j] <- nlpost(j,p[,j],p[,j-1],p[,j+1])
}
l[n] <- nlpost(n,p[,n],p[,n-1],end)

for(i in 1:iter) {
for(k in 1:step) {

## First location compares to start
pj.k <- p[,1] + rnorm(m) %*% U[,,1]

## CHECK this use of test.mask

if (lookup(pj.k[1:2], 1)) {
lj.k <- nlpost(1,pj.k, start, p[,2])
## Test candidate against l for this segment
if(l[1]-lj.k > log(runif(1))) {
## accept candidate
p[,1] <- pj.k
l[1] <- lj.k

}
}

## Middle locations
for(j in 2:(n-1))  {
pj.k <- p[,j] + rnorm(m) %*% U[,,j]
if (lookup(pj.k[1:2], j)) {
lj.k <- nlpost(j, pj.k, p[,j-1], p[,j+1])
if(l[j]-lj.k > log(runif(1))) {
## accept candidate
p[,j] <- pj.k
l[j] <- lj.k

}
}
}

## Last location compares to end
#???pj.k <- p[,n] + rnorm(n,n,m) %*% U[,,n]
pj.k <- p[,n] + rnorm(m) %*% U[,,n]
if (lookup(pj.k[2:1], n)) {
lj.k <- nlpost(n,pj.k,p[,n-1],end)
if(l[n]-lj.k > log(runif(1))) {
## accept candidate
p[,n] <- pj.k
l[n] <- lj.k

}
}

}
chain.p[i,] <- p

print(i)
}

p <- t(p)
# names(p) <- names(p0)
list(p=chain.p,last=p)

}

"old.mkLookup" <-
function (x, binArray = TRUE)
{
if (!is.list(x))
stop("x must be an image list")
csize <- c(diff(x\$x[1:2]), diff(x\$y[1:2]))
dimXY <- dim(x\$z)
function(xy, segment = 1) {
if (missing(segment) & binArray)
stop("binary arrays require segment")
if (!is.numeric(segment))
stop("segment must be numeric")
if (is.vector(xy))
xy <- matrix(xy, ncol = 2, byrow = TRUE)
if (!is.matrix(xy))
stop("xy must be a matrix or vector")
xs <- xy[, 1]
ys <- xy[, 2]
i <- round((xs - x\$x[1] + csize[1]/2)/csize[1])
j <- round((ys - x\$y[1] + csize[2]/2)/csize[2])
f <- vector(mode(x\$z), length(xs))
k <- (i > 0 & j > 0 & i <= dimXY[1] & j <= dimXY[2])
if (any(k)) {
if (binArray) {
f[k] <- bits(x\$z[i[k], j[k], (segment%/%31) +
1], (segment - 1)%%31)
f == 1
}
else {
f[k] <- x\$z[cbind(i[k], j[k])]
f
}
}
else FALSE
}
}

k.prior <-
function (seg, ps)
dnorm(ps[3], 0, 10)
```

## Try the tripEstimation package in your browser

Any scripts or data that you put into this service are public.

tripEstimation documentation built on May 2, 2019, 4:59 p.m.