Nothing
#' Creates a sequence of images showing predefined steps of warping two meshes
#' or landmark configurations (2D and 3D) into each other
#'
#' given two landmark configurations or two meshes with the same amount of
#' vertices and faces (e.g a mesh and its warped counterpart), the starting
#' configuration/mesh will be subsequently transformed into the final
#' configuration/mesh by splitting the differences into a predefined set of
#' steps.
#'
#' A series of png files will be saved to disk. These can be joined to animated
#' gifs by external programs such as imagemagick or used to create animations
#' in PDFs in a latex environment (e.g. latex package: aninmate).
#' @title Creates a sequence of images showing predefined steps of warping two meshes or landmark configurations (2D and 3D) into each other
#'
#' @param x mesh to start with (object of class mesh3d)
#' @param y resulting mesh (object of class mesh3d), having the same amount of
#' vertices and faces than the starting mesh
#' @param n integer: amount of intermediate steps.
#' @param col color of the mesh
#' @param palindrome logical: if TRUE, the procedure will go forth and back.
#' @param folder character: output folder for created images (optional)
#' @param movie character: name of the output files
#' @param add logical: if TRUE, the movie will be added to the focussed
#' rgl-windows.
#' @param close logical: if TRUE, the rgl window will be closed when finished.
#' width and 200 the height of the image.
#' @param countbegin integer: number to start image sequence.
#'
#' @param ask logical: if TRUE, the viewpoint can be selected manually.
#' @param radius numeric: define size of spheres (overides atuomatic size
#' estimation).
#' @param xland optional argument: add landmarks on mesh x
#' @param yland optional argument: add landmarks on mesh y
#' @param lmcol optional argument: color of landmarks xland and yland
#' @param links vector or list of vectors containing wireframe information to
#' connect landmarks (optional).
#' @param lwd numeric: controls width of lines defined by "links".
#' @param imagedim character of pattern "100x200" where 100 determines the
#' width and 200 the height of the image.
#' @param par list of graphial parameters: details can be found here:
#' \code{\link{par}}.
#' @param \dots additional arguments passed to \code{\link{shade3d}} (3D) or
#' \code{\link{points}} (2D).
#' @author Stefan Schlager
#' @seealso
#' \code{\link{ply2mesh},\link{file2mesh},\link{mesh2ply},\link{tps3d}}
#'
#' @examples
#'
#'
#' ###3D example
#' data(nose)##load data
#' if (interactive()){
#' ##warp a mesh onto another landmark configuration:
#' longnose.mesh <- tps3d(shortnose.mesh,shortnose.lm,longnose.lm,threads=1)
#'
#' warpmovie3d(shortnose.mesh,longnose.mesh,n=15)## create 15 images.
#'
#' ### ad some landmarks
#' warpmovie3d(shortnose.mesh,longnose.mesh,n=15,xland=shortnose.lm,
#' yland=longnose.lm)## create 15 images.
#'
#'
#' ### restrict to landmarks
#' warpmovie3d(shortnose.lm,longnose.lm,n=15,movie="matrixmovie")## create 15 images.
#'
#' ### the images are now stored in your current working directory and can
#' ### be concatenated to a gif using an external program such as
#' ### imagemagick.
#' }
#' ### 2D example
#' if (require(shapes)) {
#' bb <- procSym(gorf.dat)
#' ### morph superimposed first specimen onto sample mean
#' warpmovie2d(bb$rotated[,,1],bb$mshape,n=20,links=c(1,5,4:2,8:6,1),imagedim="600x400")
#' ## remove files
#' unlink("warpmovie00*")
#' }
#' @rdname warpmovie3d
#' @export
warpmovie3d <- function (x,y,n,col="green",palindrome=FALSE,folder=NULL,movie="warpmovie",...) UseMethod("warpmovie3d")
#' @rdname warpmovie3d
#' @method warpmovie3d matrix
#' @export
warpmovie3d.matrix <- function(x,y,n,col="green",palindrome=FALSE,folder=NULL,movie="warpmovie",add=FALSE,close=TRUE,countbegin=0,ask=TRUE,radius=NULL,links=NULL,lwd=1,...) {
if(!is.null(folder)) {
if (substr(folder,start=nchar(folder),stop=nchar(folder)) != "/")
folder <- paste(folder,"/",sep="")
dir.create(folder,showWarnings=F)
movie <- paste(folder, movie, sep="")
}
if (!add)
open3d()
k <- dim(x)[1]
if (is.null(radius))
radius <- (cSize(x)/sqrt(k))*(1/80)
## get bbox
bbox <- apply(rbind(x,y),2,range)
bbox <- expand.grid(bbox[,1],bbox[,2],bbox[,3])
points3d(bbox,col="white")
for (i in 0:n) {
mesh <- x
mesh <- (i/n)*y+(1-(i/n))*x
a <- spheres3d(mesh,col=col,radius=radius,...)
if (!is.null(links)) {
a1 <- lineplot(mesh,links,col=col,lwd=lwd)
a <- append(a,a1)
}
if (i ==0 && ask==TRUE && interactive())
readline("please select view and press return\n")
filename <- sprintf("%s%04d.png", movie, countbegin+i)
rgl.snapshot(filename,fmt="png")
pop3d("shapes",id=a)
}
if (palindrome) {## go the other way ##
for (i in 1:(n-1)) {
mesh <- x
mesh <- (i/n)*x+(1-(i/n))*y
a <- spheres3d(mesh,col=col,radius=radius,...)
if (!is.null(links)) {
a1 <- lineplot(mesh,links,col=col,lwd=lwd)
a <- append(a,a1)
}
filename <- sprintf("%s%04d.png", movie, countbegin+i+n)
rgl.snapshot(filename,fmt="png")
pop3d("shapes",id=a)
}
}
if (close)
close3d()
}
#' @rdname warpmovie3d
#' @export
warpmovie2d <- function(x,y,n,col="green",palindrome=FALSE,folder=NULL,movie="warpmovie",links=NULL,lwd=1,imagedim = "800x800",par=list(xaxt="n",yaxt="n",bty="n"),...)
{
wdold <- getwd()
widxheight <- as.integer(strsplit(imagedim, split = "x")[[1]])
if(!is.null(folder)) {
if (substr(folder,start=nchar(folder),stop=nchar(folder)) != "/")
folder <- paste(folder,"/",sep="")
dir.create(folder,showWarnings=F)
movie <- paste(folder,movie,sep="")
}
## get bbox
bbox <- apply(rbind(x,y),2,range)
bbox <- expand.grid(bbox[,1],bbox[,2])
for (i in 0:n) {
mesh <- x
mesh <- (i/n)*y+(1-(i/n))*x
filename <- sprintf("%s%04d.png", movie, i)
png(filename,width = widxheight[1], height = widxheight[2])
par(par)
plot(bbox,asp=1,cex=0,xlab="",ylab="")
points(mesh,col=col,...)
if (!is.null(links))
lineplot(mesh,links,col=col,lwd=lwd)
dev.off()
}
if (palindrome) {## go the other way ##
for (i in 1:(n-1)) {
mesh <- x
mesh <- (i/n)*x+(1-(i/n))*y
filename <- sprintf("%s%03d.png", movie, i+n)
png(filename,width = widxheight[1], height = widxheight[2])
par(par)
plot(bbox,asp=1,cex=0)
points(mesh,col=col,...)
if (!is.null(links))
lineplot(mesh,links,col=col,lwd=lwd)
dev.off()
}
}
}
Any scripts or data that you put into this service are public.
Add the following code to your website.
For more information on customizing the embed code, read Embedding Snippets.