R/mesh2ply.r

In zarquon42b/Morpho: Calculations and Visualisations Related to Geometric Morphometrics

#' export mesh objects to disk.
#' 
#' export an object of class \code{mesh3d} or a set of coordinates to a common
#' mesh file.
#' 
#' 
#' @title export mesh objects to disk
#' @param x object of class \code{mesh3d} - see rgl documentation for further
#' details or a matrix containing vertices, this can either be a \code{k x 3}
#' or a \code{3 x k} matrix, with rows or columns containing vertex
#' coordinates.
#' @param filename character: Path/name of the requested output - extension
#' will be added atuomatically. If not specified, the file will be named as the
#' exported object.
#' @param col Writes color information to ply file. Can be either a single
#' color value or a vector containing a color value for each vertex of the
#' mesh.
#' @param writeNormals logical: if TRUE, existing normals of a mesh are written
#' to file - can slow things down for very large meshes.
#' @author Stefan Schlager
#' @note meshes containing quadrangular faces will be converted to triangular meshes by splitting the faces.
#' Additionally, mesh2obj is now simply a wrapper of \code{Rvcg::vcgObjWrite}.
#' @seealso \code{\link{ply2mesh}, \link{quad2trimesh} }
#' 
#' @examples
#' 
#' require(rgl)
#' vb <- c(-1.8,-1.8,-1.8,1.0,1.8,-1.8,-1.8,1.0,-1.8,1.8,-1.8,1.0,1.8,
#' 1.8,-1.8,1.0,-1.8,-1.8,1.8,1.0,1.8,
#' -1.8,1.8,1.0,-1.8,1.8,1.8,1.0,1.8,1.8,1.8,1.0)
#' it <- c(2,1,3,3,4,2,3,1,5,5,7,3,5,1,2,2,6,5,6,8,7,7,5,6,7,8,4,4,3,7,4,8,6,6,2,4)
#' vb <- matrix(vb,4,8) ##create vertex matrix
#' it <- matrix(it,3,12) ## create face matrix
#' cube<-list(vb=vb,it=it)
#' class(cube) <- "mesh3d"
#'\dontrun{
#' shade3d(cube,col=3) ## view the green cube
#' }
#' mesh2ply(cube,filename="cube") # write cube to a file called cube.ply
#' unlink("cube.ply")
#' @rdname mesh2ply
#' @export
mesh2ply <- function(x, filename=dataname, col=NULL, writeNormals=FALSE)
{	
    dataname <- deparse(substitute(x))
    if (is.matrix(x)) {
        dimsx <- dim(x)
        if (dimsx[2] == 3 && dimsx[1] != 3)
            x <- t(x)
        x <- list(vb=x)
    }
    if (!is.null(x$ib))
        x <- quad2trimesh(x)
    
		if (is.character(filename)) {
	    filename <- paste(filename,".ply",sep="")
		}

    vert <- x$vb[1:3,]
    vert <- round(vert,digits=6)
    if (!is.null(x$it)) {
        face <- x$it-1
        fd <- 3
        fn <- dim(face)[2]
    } else
        fn <- 0
    
    vert.all <- vert
    vn <- dim(vert)[2]
    ##vn.all <- 3
    texfile <- x$TextureFile

    if (is.null(col) && !is.null(x$material$color)) {
        ## col=rep("#FFFFFF",vn)
        ## tmp1 <- data.frame(it=as.vector(x$it))
        ## tmp1$rgb <- as.vector(x$material$color)
        ## tmp1 <- unique(tmp1)
        ## col[tmp1$it] <- tmp1$rgb
        col <- x$material$color
    }
    if (!writeNormals)
        x$normals <- NULL
    
### start writing to file ###
    
### write header ###
    cat("ply\nformat ascii 1.0\ncomment MORPHO generated\n",file=filename)
    
### check for Texture information and write to header ###	
    
    if (is.character(texfile))
        cat(paste("comment TextureFile ",texfile,"\n",sep=""),file=filename,append=TRUE) 
    
    
### write vertex infos to header ###
    
    v.info <- paste("element vertex ",vn,"\n","property float x\nproperty float y\nproperty float z\n",sep="")
    
    cat(v.info,file=filename,append=TRUE)	
    if (!is.null(x$normals)) {
        cat("property float nx\nproperty float ny\nproperty float nz\n",file=filename,append=TRUE)
        norma <- round(x$normals[1:3,],digits=6)
        vert.all <- rbind(vert,norma)	
        ##vn.all <- 6		
    }
    if (!is.null(col))    
        v.info <- cat("property uchar red\nproperty uchar green\nproperty uchar blue\n",file=filename,append=T)
    
### write face infos and texture infos to header and finish ###	
    
    cat(paste("element face ",fn,"\n",sep=""),file=filename,append=TRUE)	
    if(!is.null(x$tex) && is.character(texfile)) {
        cat("property list uchar int vertex_indices\nproperty list uchar float texcoord\nend_header\n",file=filename,append=TRUE)	
    } else
        cat("property list uchar int vertex_indices\nend_header\n",file=filename,append=TRUE)	
    
### write vertices and vertex normals ###
    vert.all <- data.frame(t(vert.all))
    if (!is.null(col)) {
        colout <- t(col2rgb(col))
             
        vert.all <- cbind(vert.all,colout)
    }
    
    write.table(format(vert.all,scientific=F,trim=T),file=filename,sep=" ",append=TRUE, quote = FALSE, row.names = FALSE, col.names = FALSE, na = "")	
    ##write face and Texture information ###	
    if (!is.null(x$it)){
	if(!is.null(x$tex) && !is.null(x$TextureFile)) {
            tex <- t(x$tex)
            texn <- dim(tex)[2]
            faceraw <- rbind(fd,face)
            facetex <- t(cbind(texn,tex))
            write.table(format(t(rbind(faceraw,facetex)),scientific=F,trim=T),file=filename,sep=" ",append=TRUE,quote = FALSE, row.names = FALSE, col.names = FALSE, na = "")			
        } else 
            write.table(format(t(rbind(fd,face)),scientific=F,trim=T),file=filename,sep=" ",append=TRUE,quote = FALSE, row.names = FALSE, col.names = FALSE, na = "")	
    }
}