ctmm animations
347 views
Skip to first unread message
Christen Fleming
Feb 17, 2021, 10:54:08 AM2/17/21
to ctmm R user group
Hi Folks,
I've coded some basic animation capabilities into ctmm, which you can find in the development branch on GitHub. See help("video") after updating the package from GitHub.
I used this functionality to give a short presentation on the basic movement models in the ctmm Youtube channel: https://www.youtube.com/watch?v=5S45TD4bnp8
Expect more demonstrations and tutorials to be uploaded there in the future.
The R script used to generate the above animations, animations.R, is attached to this post.
Best,
Chris
Christen Fleming
Feb 17, 2021, 11:04:49 AM2/17/21
to ctmm R user group
Google is refusing to let me attach this script, so I'm just going to paste it below:
# Animation functions are not currently on CRAN
devtools::install_github("ctmm-initiative/ctmm")
library(ctmm)
data(buffalo)
DATA <- buffalo[[3]] # take one buffalo
projection(DATA) <- median(DATA) # center origin for single buffalo
plot(DATA)
compass() # north is now up in this projection
## select a continuous-time model
SVF <- variogram(DATA)
GUESS <- ctmm.guess(DATA,variogram=SVF,CTMM=ctmm(error=FALSE),interactive=FALSE)
FIT <- ctmm.select(DATA,GUESS,trace=2)
# extent of the data
EXT <- extent(DATA)
# make extent include a simulated buffalo to the right
EXT$x[2] <- EXT$x[2] + diff(EXT$x)
COL <- c('blue','red') # color for data and simulation
TAU <- FIT$tau # position and velocity autocorrelation timescale
RES <- c(round(diff(EXT$x)/diff(EXT$y)),1) * 1080 # aiming for subset of 1080p
### In the following examples I am cheating for the misspecified models and making them better than they would be if fitting them to the data with ctmm.fit()
# Fitting a misspecified model will induce bias when missing features become "explained" by available features
## Independent locations (IID)
IID <- FIT
IID$mu[1] <- IID$mu[1] + diff(EXT$x)/2 # shift to the right
IID$tau <- NULL # delete all autocorrelation timescales
# simulate based on IID model
# keeping the same location covariance
SIM <- simulate(IID,t=DATA$t)
main <- "African buffalo vesus Independent locations"
file <- "IID.mp4"
video(list(DATA,SIM),ext=EXT,fps=30,pch=16,ghost=TAU[2],file=file,res=RES,col=COL,main=main,cex=2,cex.axis=2,cex.lab=2,cex.main=2,par.list=list(mar=c(5,6,4,1)+0.1))
## Brownian motion (BM)
# keeping the same diffusion rate
BM <- FIT
BM$mu[1] <- BM$mu[1] + diff(EXT$x)/2 # shift to the right
BMrange <- FALSE # not range resident
BMsigma <- ctmm:::scale.covm(BM$sigma,1/BM$tau[1]) # match diffusion rate - not necessary to understand
BMtau <- Inf # infinite range crossing timescale, and no velocity autocorrelation timescale
# simulate based on BM model
SIM <- simulate(BM,t=DATA$t)
main <- "African buffalo vesus Brownian motion"
file <- "BM.mp4"
video(list(DATA,SIM),ext=EXT,fps=30,pch=16,ghost=TAU[2],file=file,res=RES,col=COL,main=main,cex=2,cex.axis=2,cex.lab=2,cex.main=2,par.list=list(mar=c(5,6,4,1)+0.1))
## Ornstein-Uhlenbeck (OU) motion
# keeping the same tau[position] and diffusion rate
OU <- FIT
OU$mu[1] <- OU$mu[1] + diff(EXT$x)/2 # shift to the right
OU$tau <- OU$tau[1] # keep only home-range crossing timescale
# simulate based on OU model
SIM <- simulate(OU,t=DATA$t)
main <- "African buffalo vesus Ornstein-Uhlenbeck motion"
file <- "OU.mp4"
video(list(DATA,SIM),ext=EXT,fps=30,pch=16,ghost=TAU[2],file=file,res=RES,col=COL,main=main,cex=2,cex.axis=2,cex.lab=2,cex.main=2,par.list=list(mar=c(5,6,4,1)+0.1))
## integrated Ornstein-Uhlenbeck (IOU) motion
# keeping the same tau[velocity] and diffusion rate
IOU <- FIT
IOU$mu[1] <- IOU$mu[1] + diff(EXT$x)/2 # shift to the right
IOU$range <- FALSE # not range resident
IOU$sigma <- ctmm:::scale.covm(IOU$sigma,1/IOU$tau[1]) # match diffusion rate - not necessary to understand
IOU$tau[1] <- Inf # set range crossing timescale to be infinite, and keep velocity autocorrelation timescale
# simulate based on IOU model
SIM <- simulate(IOU,t=DATA$t)
main <- "African buffalo vesus Integrated Ornstein-Uhlenbeck motion"
file <- "IOU.mp4"
video(list(DATA,SIM),ext=EXT,fps=30,pch=16,ghost=TAU[2],file=file,res=RES,col=COL,main=main,cex=2,cex.axis=2,cex.lab=2,cex.main=2,par.list=list(mar=c(5,6,4,1)+0.1))
## OUf motion (BONUS)
# keeping the same RMS speed
OUf <- FIT
OUf$mu[1] <- OUf$mu[1] + diff(EXT$x)/2 # shift to the right
OUf$tau <- c(1,1)*sqrt(prod(FIT$tau)) # average autocorrelation decay rates
# simulate based on OUf model
SIM <- simulate(OUf,t=DATA$t)
main <- "African buffalo vesus OUf motion"
file <- "OUf.mp4" # Windows is not case sensitive and this will be overwritten by "OUF.mp4"
video(list(DATA,SIM),ext=EXT,fps=30,pch=16,ghost=TAU[2],file=file,res=RES,col=COL,main=main,cex=2,cex.axis=2,cex.lab=2,cex.main=2,par.list=list(mar=c(5,6,4,1)+0.1))
## OUF motion
OUF <- FIT
OUF$mu[1] <- OUF$mu[1] + diff(EXT$x)/2 # shift to the right
# simulate based on OUF model
SIM <- simulate(OUF,t=DATA$t)
main <- "African buffalo vesus OUF motion"
file <- "OUF.mp4"
video(list(DATA,SIM),ext=EXT,fps=30,pch=16,ghost=TAU[2],file=file,res=RES,col=COL,main=main,cex=2,cex.axis=2,cex.lab=2,cex.main=2,par.list=list(mar=c(5,6,4,1)+0.1))
### Now I am going to coarsen and truncate the data to make it more like the models that didn't look good before
## truncate the data to one range crossing
plot(SVF,xlim=c(0,TAU[1]))
SUB <- DATA$t-DATA$t[1] <= TAU[1]
SUB <- DATA[SUB,]
EXT$t <- extent(SUB)$t
# simulate based on IOU model
SIM <- simulate(IOU,t=SUB$t)
main <- "African buffalo vesus IOU motion (truncated)"
file <- "IOU2.mp4"
video(list(SUB,SIM),ext=EXT,fps=30,pch=16,ghost=TAU[2],file=file,res=RES,col=COL,main=main,cex=2,cex.axis=2,cex.lab=2,cex.main=2,par.list=list(mar=c(5,6,4,1)+0.1))
## thin the data to independent velocities (95%)
SUB <- rep(FALSE,nrow(DATA)) # data points to keep
LAST <- 1 # last data point kept
SUB[LAST] <- TRUE
for(i in 2:nrow(DATA))
{
if(DATA$t[i]-DATA$t[LAST] >= 3*TAU[2]) # thin to 3 x velocity autocorrelation timescale
{
LAST <- i
SUB[LAST] <- TRUE
}
}
SUB <- DATA[SUB,]
EXT$t <- extent(SUB)$t
# simulate based on OU model
SIM <- simulate(OU,t=SUB$t)
main <- "African buffalo vesus OU motion (thinned)"
file <- "OU2.mp4"
video(list(SUB,SIM),ext=EXT,fps=30,pch=16,ghost=TAU[2],file=file,res=RES,col=COL,main=main,cex=2,cex.axis=2,cex.lab=2,cex.main=2,par.list=list(mar=c(5,6,4,1)+0.1))
## thin the data to independent velocities (95%) & truncate the data to one range crossing
SUB <- rep(FALSE,nrow(DATA)) # data points to keep
LAST <- 1 # last data point kept
SUB[LAST] <- TRUE # kept it
for(i in 2:nrow(DATA))
{
if(DATA$t[i]-DATA$t[LAST] >= 3*TAU[2]) # thin to 3 x velocity autocorrelation timescale
{
LAST <- i
SUB[LAST] <- TRUE
}
if(DATA$t[i]-DATA$t[1] > TAU[1]) { break }
}
SUB <- DATA[SUB,]
EXT$t <- extent(SUB)$t
# simulate based on BM model
SIM <- simulate(BM,t=SUB$t)
main <- "African buffalo vesus BM motion (thinned & truncated)"
file <- "BM2.mp4"
video(list(SUB,SIM),ext=EXT,fps=30,pch=16,ghost=TAU[2],file=file,res=RES,col=COL,main=main,cex=2,cex.axis=2,cex.lab=2,cex.main=2,par.list=list(mar=c(5,6,4,1)+0.1))
## thin the data to independent locations (95%)
SUB <- rep(FALSE,nrow(DATA)) # data points to keep
LAST <- 1 # last data point kept
SUB[LAST] <- TRUE
for(i in 2:nrow(DATA))
{
if(DATA$t[i]-DATA$t[LAST] >= 3*TAU[1]) # thin to 3 x position autocorrelation timescale
{
LAST <- i
SUB[LAST] <- TRUE
}
}
SUB <- DATA[SUB,]
EXT$t <- extent(SUB)$t
# simulate based on IID model
SIM <- simulate(IID,t=SUB$t)
main <- "African buffalo vesus IID motion (thinned & thinned)"
file <- "IID2.mp4"
video(list(SUB,SIM),ext=EXT,fps=30,pch=16,ghost=TAU[2],file=file,res=RES,col=COL,main=main,cex=2,cex.axis=2,cex.lab=2,cex.main=2,par.list=list(mar=c(5,6,4,1)+0.1))
### thumbnail code
OD <- occurrence(DATA,FIT)
RD <- akde(DATA,FIT,weights=TRUE,res=100,trace=TRUE)
uere(DATA) <- 10
plot(DATA,UD=list(RD,OD),col='red',col.DF=c('blue','purple'),col.level=NA,col.grid=NA,error=2)
devtools::install_github("ctmm-initiative/ctmm")
library(ctmm)
data(buffalo)
DATA <- buffalo[[3]] # take one buffalo
projection(DATA) <- median(DATA) # center origin for single buffalo
plot(DATA)
compass() # north is now up in this projection
## select a continuous-time model
SVF <- variogram(DATA)
GUESS <- ctmm.guess(DATA,variogram=SVF,CTMM=ctmm(error=FALSE),interactive=FALSE)
FIT <- ctmm.select(DATA,GUESS,trace=2)
# extent of the data
EXT <- extent(DATA)
# make extent include a simulated buffalo to the right
EXT$x[2] <- EXT$x[2] + diff(EXT$x)
COL <- c('blue','red') # color for data and simulation
TAU <- FIT$tau # position and velocity autocorrelation timescale
RES <- c(round(diff(EXT$x)/diff(EXT$y)),1) * 1080 # aiming for subset of 1080p
### In the following examples I am cheating for the misspecified models and making them better than they would be if fitting them to the data with ctmm.fit()
# Fitting a misspecified model will induce bias when missing features become "explained" by available features
## Independent locations (IID)
IID <- FIT
IID$mu[1] <- IID$mu[1] + diff(EXT$x)/2 # shift to the right
IID$tau <- NULL # delete all autocorrelation timescales
# simulate based on IID model
# keeping the same location covariance
SIM <- simulate(IID,t=DATA$t)
main <- "African buffalo vesus Independent locations"
file <- "IID.mp4"
video(list(DATA,SIM),ext=EXT,fps=30,pch=16,ghost=TAU[2],file=file,res=RES,col=COL,main=main,cex=2,cex.axis=2,cex.lab=2,cex.main=2,par.list=list(mar=c(5,6,4,1)+0.1))
## Brownian motion (BM)
# keeping the same diffusion rate
BM <- FIT
BM$mu[1] <- BM$mu[1] + diff(EXT$x)/2 # shift to the right
BMrange <- FALSE # not range resident
BMsigma <- ctmm:::scale.covm(BM$sigma,1/BM$tau[1]) # match diffusion rate - not necessary to understand
BMtau <- Inf # infinite range crossing timescale, and no velocity autocorrelation timescale
# simulate based on BM model
SIM <- simulate(BM,t=DATA$t)
main <- "African buffalo vesus Brownian motion"
file <- "BM.mp4"
video(list(DATA,SIM),ext=EXT,fps=30,pch=16,ghost=TAU[2],file=file,res=RES,col=COL,main=main,cex=2,cex.axis=2,cex.lab=2,cex.main=2,par.list=list(mar=c(5,6,4,1)+0.1))
## Ornstein-Uhlenbeck (OU) motion
# keeping the same tau[position] and diffusion rate
OU <- FIT
OU$mu[1] <- OU$mu[1] + diff(EXT$x)/2 # shift to the right
OU$tau <- OU$tau[1] # keep only home-range crossing timescale
# simulate based on OU model
SIM <- simulate(OU,t=DATA$t)
main <- "African buffalo vesus Ornstein-Uhlenbeck motion"
file <- "OU.mp4"
video(list(DATA,SIM),ext=EXT,fps=30,pch=16,ghost=TAU[2],file=file,res=RES,col=COL,main=main,cex=2,cex.axis=2,cex.lab=2,cex.main=2,par.list=list(mar=c(5,6,4,1)+0.1))
## integrated Ornstein-Uhlenbeck (IOU) motion
# keeping the same tau[velocity] and diffusion rate
IOU <- FIT
IOU$mu[1] <- IOU$mu[1] + diff(EXT$x)/2 # shift to the right
IOU$range <- FALSE # not range resident
IOU$sigma <- ctmm:::scale.covm(IOU$sigma,1/IOU$tau[1]) # match diffusion rate - not necessary to understand
IOU$tau[1] <- Inf # set range crossing timescale to be infinite, and keep velocity autocorrelation timescale
# simulate based on IOU model
SIM <- simulate(IOU,t=DATA$t)
main <- "African buffalo vesus Integrated Ornstein-Uhlenbeck motion"
file <- "IOU.mp4"
video(list(DATA,SIM),ext=EXT,fps=30,pch=16,ghost=TAU[2],file=file,res=RES,col=COL,main=main,cex=2,cex.axis=2,cex.lab=2,cex.main=2,par.list=list(mar=c(5,6,4,1)+0.1))
## OUf motion (BONUS)
# keeping the same RMS speed
OUf <- FIT
OUf$mu[1] <- OUf$mu[1] + diff(EXT$x)/2 # shift to the right
OUf$tau <- c(1,1)*sqrt(prod(FIT$tau)) # average autocorrelation decay rates
# simulate based on OUf model
SIM <- simulate(OUf,t=DATA$t)
main <- "African buffalo vesus OUf motion"
file <- "OUf.mp4" # Windows is not case sensitive and this will be overwritten by "OUF.mp4"
video(list(DATA,SIM),ext=EXT,fps=30,pch=16,ghost=TAU[2],file=file,res=RES,col=COL,main=main,cex=2,cex.axis=2,cex.lab=2,cex.main=2,par.list=list(mar=c(5,6,4,1)+0.1))
## OUF motion
OUF <- FIT
OUF$mu[1] <- OUF$mu[1] + diff(EXT$x)/2 # shift to the right
# simulate based on OUF model
SIM <- simulate(OUF,t=DATA$t)
main <- "African buffalo vesus OUF motion"
file <- "OUF.mp4"
video(list(DATA,SIM),ext=EXT,fps=30,pch=16,ghost=TAU[2],file=file,res=RES,col=COL,main=main,cex=2,cex.axis=2,cex.lab=2,cex.main=2,par.list=list(mar=c(5,6,4,1)+0.1))
### Now I am going to coarsen and truncate the data to make it more like the models that didn't look good before
## truncate the data to one range crossing
plot(SVF,xlim=c(0,TAU[1]))
SUB <- DATA$t-DATA$t[1] <= TAU[1]
SUB <- DATA[SUB,]
EXT$t <- extent(SUB)$t
# simulate based on IOU model
SIM <- simulate(IOU,t=SUB$t)
main <- "African buffalo vesus IOU motion (truncated)"
file <- "IOU2.mp4"
video(list(SUB,SIM),ext=EXT,fps=30,pch=16,ghost=TAU[2],file=file,res=RES,col=COL,main=main,cex=2,cex.axis=2,cex.lab=2,cex.main=2,par.list=list(mar=c(5,6,4,1)+0.1))
## thin the data to independent velocities (95%)
SUB <- rep(FALSE,nrow(DATA)) # data points to keep
LAST <- 1 # last data point kept
SUB[LAST] <- TRUE
for(i in 2:nrow(DATA))
{
if(DATA$t[i]-DATA$t[LAST] >= 3*TAU[2]) # thin to 3 x velocity autocorrelation timescale
{
LAST <- i
SUB[LAST] <- TRUE
}
}
SUB <- DATA[SUB,]
EXT$t <- extent(SUB)$t
# simulate based on OU model
SIM <- simulate(OU,t=SUB$t)
main <- "African buffalo vesus OU motion (thinned)"
file <- "OU2.mp4"
video(list(SUB,SIM),ext=EXT,fps=30,pch=16,ghost=TAU[2],file=file,res=RES,col=COL,main=main,cex=2,cex.axis=2,cex.lab=2,cex.main=2,par.list=list(mar=c(5,6,4,1)+0.1))
## thin the data to independent velocities (95%) & truncate the data to one range crossing
SUB <- rep(FALSE,nrow(DATA)) # data points to keep
LAST <- 1 # last data point kept
SUB[LAST] <- TRUE # kept it
for(i in 2:nrow(DATA))
{
if(DATA$t[i]-DATA$t[LAST] >= 3*TAU[2]) # thin to 3 x velocity autocorrelation timescale
{
LAST <- i
SUB[LAST] <- TRUE
}
if(DATA$t[i]-DATA$t[1] > TAU[1]) { break }
}
SUB <- DATA[SUB,]
EXT$t <- extent(SUB)$t
# simulate based on BM model
SIM <- simulate(BM,t=SUB$t)
main <- "African buffalo vesus BM motion (thinned & truncated)"
file <- "BM2.mp4"
video(list(SUB,SIM),ext=EXT,fps=30,pch=16,ghost=TAU[2],file=file,res=RES,col=COL,main=main,cex=2,cex.axis=2,cex.lab=2,cex.main=2,par.list=list(mar=c(5,6,4,1)+0.1))
## thin the data to independent locations (95%)
SUB <- rep(FALSE,nrow(DATA)) # data points to keep
LAST <- 1 # last data point kept
SUB[LAST] <- TRUE
for(i in 2:nrow(DATA))
{
if(DATA$t[i]-DATA$t[LAST] >= 3*TAU[1]) # thin to 3 x position autocorrelation timescale
{
LAST <- i
SUB[LAST] <- TRUE
}
}
SUB <- DATA[SUB,]
EXT$t <- extent(SUB)$t
# simulate based on IID model
SIM <- simulate(IID,t=SUB$t)
main <- "African buffalo vesus IID motion (thinned & thinned)"
file <- "IID2.mp4"
video(list(SUB,SIM),ext=EXT,fps=30,pch=16,ghost=TAU[2],file=file,res=RES,col=COL,main=main,cex=2,cex.axis=2,cex.lab=2,cex.main=2,par.list=list(mar=c(5,6,4,1)+0.1))
### thumbnail code
OD <- occurrence(DATA,FIT)
RD <- akde(DATA,FIT,weights=TRUE,res=100,trace=TRUE)
uere(DATA) <- 10
plot(DATA,UD=list(RD,OD),col='red',col.DF=c('blue','purple'),col.level=NA,col.grid=NA,error=2)
Francisco Castellanos
Feb 17, 2021, 2:33:36 PM2/17/21
to Christen Fleming, ctmm R user group
Christen,
This is amazing, thank you for putting this together. I'd certainly give it a try since I'm also animating animal movements with the moveVis package. I'm looking forward to seeing you in the seminar.
Regards,
Francisco
--
You received this message because you are subscribed to the Google Groups "ctmm R user group" group.
To unsubscribe from this group and stop receiving emails from it, send an email to ctmm-user+...@googlegroups.com.
To view this discussion on the web visit https://groups.google.com/d/msgid/ctmm-user/b791d6c1-65b0-4200-ad7d-259a6d073db2n%40googlegroups.com.
--
Francisco X. Castellanos
M. Sc. Student
The Ray Laboratory
Department of Biological Sciences
Texas Tech University
Reply all
Reply to author
Forward
0 new messages