├── .gitignore ├── data ├── nose.rda └── boneData.rda ├── tests ├── testthat.R └── testthat │ ├── testdata │ ├── rW.rds │ ├── CVA.rds │ ├── slider3d.rds │ └── pls-baseline.rds │ ├── test-CVA.r │ ├── test-relWarps.r │ ├── test-pls2B.r │ ├── test-slider3d.r │ └── test-mirror.r ├── inst ├── extdata │ └── SCP1.ply ├── COPYRIGHTS └── CITATION ├── R ├── onUnload.r ├── fx.r ├── scaleproc.r ├── file2mesh.r ├── write.obj.r ├── read.obj.r ├── colors.r ├── crossp.r ├── gdif.r ├── createVarTable.r ├── difplot.lm2D.r ├── eigenPCA.r ├── orp.r ├── cSize.r ├── ang.r ├── armaGinv.r ├── mesh2obj.r ├── meshcube.r ├── difplot.lm.r ├── conv2backf.r ├── angle.calc.r ├── calcGamma.r ├── list2array.r ├── createMissingList.r ├── line2plane.r ├── addo.r ├── read.pts.r ├── meshDistZExport.r ├── meshres.r ├── obj2mesh.r ├── mesh2grey.r ├── quad2trimesh.r ├── barycenter.r ├── groupPCAcrova.r ├── r2morphoj.r ├── kendalldist.r ├── plot.normals.r ├── write.pts.r ├── symmetrize.r ├── rot.proc.r ├── tanplan.r ├── solutionSpace.r ├── scalemesh.r ├── projRead.r ├── r2morphologika.r ├── ray2mesh.r ├── cExtract.r ├── read.lmdta.r ├── qqmat.r ├── ignoreNA.r ├── read.mpp.r ├── rotonmat.r └── lineplot.r ├── .Rbuildignore ├── src ├── asymPerm.h ├── Makevars ├── CubeStuff.h ├── CVAdists.h ├── armaGinvCpp.h ├── permudistArma.h ├── updateNormals.h ├── doozers.h ├── barycenter.cpp ├── addCube.h ├── armaGinvCpp.cpp ├── covPCA.h ├── points2mesh.h ├── face_zero.cpp ├── createL.cpp ├── ang_calc.cpp ├── meshres.cpp ├── fastSubsetMeans.cpp ├── edgePlane.cpp ├── permudistArma.cpp ├── doozers.cpp ├── tpsfx.cpp ├── tweakU.cpp └── CVAdists.cpp ├── man ├── read.fcsv.Rd ├── list2array.Rd ├── getFaces.Rd ├── cSize.Rd ├── armaGinv.Rd ├── mesh2grey.Rd ├── colors.Rd ├── getTrafo4x4.Rd ├── areaSphere.Rd ├── boneData.Rd ├── meshres.Rd ├── meshcube.Rd ├── write.fcsv.Rd ├── arrMean3.Rd ├── kendalldist.Rd ├── areaSpherePart.Rd ├── nose.Rd ├── rotaxisMat.Rd ├── Morpho-deprecated.Rd ├── angle.calc.Rd ├── getPLSscores.Rd ├── invertFaces.Rd ├── read.lmdta.Rd ├── read.pts.Rd ├── getTrafoRotaxis.Rd ├── line2plane.Rd ├── read.mpp.Rd ├── plotNormals.Rd ├── getPLSfromScores.Rd ├── barycenter.Rd ├── quad2trimesh.Rd ├── mergeMeshes.Rd ├── predictPLSfromScores.Rd ├── readallTPS.Rd ├── createMissingList.Rd ├── getPCscores.Rd ├── cExtract.Rd ├── classify.Rd ├── plot.slider3d.Rd ├── predictPLSfromData.Rd ├── write.pts.Rd ├── cutMeshPlane.Rd ├── scalemesh.Rd ├── bindArr.Rd ├── retroDeform3d.Rd ├── plsCoVar.Rd ├── covW.Rd ├── qqmat.Rd ├── PCdist.Rd ├── readLandmarks.csv.Rd ├── meshPlaneIntersect.Rd ├── vecx.Rd ├── lineplot.Rd ├── mirror2plane.Rd ├── angleTest.Rd ├── r2morphoj.Rd ├── solutionSpace.Rd ├── showPC.Rd ├── tangentPlane.Rd ├── applyTransform.Rd ├── align2procSym.Rd ├── fastKmeans.Rd ├── symmetrize.Rd ├── mcNNindex.Rd ├── retroDeformMesh.Rd ├── anonymize.Rd ├── ply2mesh.Rd ├── predictRelWarps.Rd ├── sortCurve.Rd ├── projRead.Rd ├── getMeaningfulPCs.Rd ├── ray2mesh.Rd ├── Morpho-package.Rd ├── read.csv.folder.Rd ├── permudist.Rd ├── procAOVsym.Rd ├── rotaxis3d.Rd ├── updateNormals.Rd ├── getPCtol.Rd ├── CAC.Rd ├── plsCoVarCommonShape.Rd ├── getPLSCommonShape.Rd ├── regdist.Rd ├── exVar.Rd ├── NNshapeReg.Rd ├── name2factor.Rd ├── rotonmat.Rd ├── cutSpace.Rd ├── createAtlas.Rd ├── plotAtlas.Rd ├── computeTransform.Rd ├── pcaplot3d.Rd ├── rotmesh.onto.Rd ├── deformGrid2d.Rd ├── points2plane.Rd ├── mesh2ply.Rd ├── pcAlign.Rd ├── equidistantCurve.Rd └── histGroup.Rd ├── .travis.yml ├── DESCRIPTION └── README.md /.gitignore: -------------------------------------------------------------------------------- 1 | *.o 2 | *.so 3 | .Rproj.user 4 | -------------------------------------------------------------------------------- /data/nose.rda: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/nevrome/Morpho/master/data/nose.rda -------------------------------------------------------------------------------- /data/boneData.rda: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/nevrome/Morpho/master/data/boneData.rda -------------------------------------------------------------------------------- /tests/testthat.R: -------------------------------------------------------------------------------- 1 | library(testthat) 2 | library(Morpho) 3 | 4 | test_check("Morpho") 5 | -------------------------------------------------------------------------------- /inst/extdata/SCP1.ply: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/nevrome/Morpho/master/inst/extdata/SCP1.ply -------------------------------------------------------------------------------- /R/onUnload.r: -------------------------------------------------------------------------------- 1 | .onUnload <- function (libpath) { 2 | library.dynam.unload("Morpho", libpath) 3 | } 4 | -------------------------------------------------------------------------------- /tests/testthat/testdata/rW.rds: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/nevrome/Morpho/master/tests/testthat/testdata/rW.rds -------------------------------------------------------------------------------- /tests/testthat/testdata/CVA.rds: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/nevrome/Morpho/master/tests/testthat/testdata/CVA.rds -------------------------------------------------------------------------------- /.Rbuildignore: -------------------------------------------------------------------------------- 1 | R/covWrap.r 2 | .gitignore 3 | ^.*\.Rproj$ 4 | ^\.Rproj\.user$ 5 | .travis.yml 6 | README.md 7 | debian 8 | -------------------------------------------------------------------------------- /tests/testthat/testdata/slider3d.rds: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/nevrome/Morpho/master/tests/testthat/testdata/slider3d.rds -------------------------------------------------------------------------------- /tests/testthat/testdata/pls-baseline.rds: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/nevrome/Morpho/master/tests/testthat/testdata/pls-baseline.rds -------------------------------------------------------------------------------- /R/fx.r: -------------------------------------------------------------------------------- 1 | .fx <- function(refmat,M,coefs,time=TRUE,threads=1) { 2 | M <- cbind(1,M) 3 | splM <- .Call("tpsfx",refmat, M, t(coefs),threads) 4 | return(splM) 5 | } 6 | -------------------------------------------------------------------------------- /src/asymPerm.h: -------------------------------------------------------------------------------- 1 | #ifndef _MorphoPermute_asymPerm_H 2 | #define _MorphoPermute_asymPerm_H 3 | 4 | #include 5 | 6 | RcppExport SEXP asymPerm(SEXP asymr, SEXP groupsr, SEXP roundr); 7 | 8 | #endif 9 | -------------------------------------------------------------------------------- /src/Makevars: -------------------------------------------------------------------------------- 1 | ## Use the R_HOME indirection to support installations of multiple R version 2 | PKG_LIBS = $(LAPACK_LIBS) $(BLAS_LIBS) $(FLIBS) $(SHLIB_OPENMP_CXXFLAGS) 3 | 4 | PKG_CXXFLAGS = $(SHLIB_OPENMP_CXXFLAGS) 5 | -------------------------------------------------------------------------------- /R/scaleproc.r: -------------------------------------------------------------------------------- 1 | scaleproc <- function (arr) { 2 | if (!is.numeric(arr) || length(dim(arr)) != 3) 3 | stop("please provide 3D numeric array") 4 | out <- .Call("scaleprocCpp",arr) 5 | return(out) 6 | } 7 | 8 | -------------------------------------------------------------------------------- /R/file2mesh.r: -------------------------------------------------------------------------------- 1 | #' @rdname ply2mesh 2 | #' @importFrom Rvcg vcgImport 3 | #' @export 4 | file2mesh <- function(filename,clean=TRUE,readcol=FALSE) { 5 | mesh <- vcgImport(filename, clean=clean, readcolor=readcol) 6 | return(mesh) 7 | } 8 | 9 | -------------------------------------------------------------------------------- /R/write.obj.r: -------------------------------------------------------------------------------- 1 | write.obj <- function(obj,filename="default") 2 | { 3 | obj <- format(obj,scientific=FALSE,trim=TRUE, justify = "none") 4 | write.table(obj,file=paste(filename,".obj",sep=""),quote=F,row.names = FALSE,col.names = FALSE,na="") 5 | } 6 | -------------------------------------------------------------------------------- /src/CubeStuff.h: -------------------------------------------------------------------------------- 1 | #ifndef CUBESTUFF_H_ 2 | #define CUBESTUFF_H_ 3 | 4 | RcppExport SEXP addoCpp(SEXP array_); 5 | 6 | RcppExport SEXP arrMean3Cpp(SEXP array_); 7 | 8 | RcppExport SEXP scaleprocCpp(SEXP array_); 9 | 10 | #endif /*CUBESTUFF_H_*/ 11 | -------------------------------------------------------------------------------- /R/read.obj.r: -------------------------------------------------------------------------------- 1 | read.obj <- function(file) 2 | { 3 | test <- read.table(file, nrows=50) 4 | if(length(grep(",",test[30:50,2])) != 0) 5 | out <- read.table(file,dec=",") 6 | else 7 | out <- read.table(file) 8 | 9 | return(out) 10 | } 11 | -------------------------------------------------------------------------------- /R/colors.r: -------------------------------------------------------------------------------- 1 | skin1 <- rgb(239,208,207,max=255) 2 | skin2 <- rgb(216,185,182,max=255) 3 | skin3 <- rgb(197,127,092,max=255) 4 | skin4 <- rgb(150,073,040,max=255) 5 | 6 | bone1 <- rgb(228, 209, 192,max=255) 7 | bone2 <- rgb(255,243,170 ,max=255) 8 | bone3 <- rgb(255,250,220,max=255) 9 | -------------------------------------------------------------------------------- /src/CVAdists.h: -------------------------------------------------------------------------------- 1 | #ifndef CVA_DISTS_H_ 2 | #define CVA_DISTS_H_ 3 | 4 | #include 5 | 6 | using namespace Rcpp; 7 | using namespace arma; 8 | 9 | RcppExport SEXP CVAdists(SEXP data_, SEXP groups_, SEXP rounds_, SEXP winv_); 10 | 11 | #endif /*CVA_DISTS_H_*/ 12 | -------------------------------------------------------------------------------- /R/crossp.r: -------------------------------------------------------------------------------- 1 | #' @rdname tangentPlane 2 | #' @export 3 | crossProduct <- function(x,y) 4 | { 5 | out <- c(0,0,0) 6 | out[1] <- x[2]*y[3]-x[3]*y[2] 7 | out[2] <- x[3]*y[1]-x[1]*y[3] 8 | out[3] <- x[1]*y[2]-x[2]*y[1] 9 | out <- out/norm(out,"2") 10 | return(out) 11 | } 12 | 13 | -------------------------------------------------------------------------------- /src/armaGinvCpp.h: -------------------------------------------------------------------------------- 1 | #ifndef _armaGinvCpp_H 2 | #define _armaGinvCpp_H 3 | 4 | #include 5 | #include 6 | 7 | using namespace Rcpp; 8 | using namespace std; 9 | using namespace arma; 10 | 11 | RcppExport SEXP armaGinvCpp(SEXP matIn_, SEXP tol_); 12 | 13 | #endif 14 | -------------------------------------------------------------------------------- /src/permudistArma.h: -------------------------------------------------------------------------------- 1 | #ifndef PERMUDIST_H_ 2 | #define PERMUDIST_H_ 3 | 4 | #include 5 | using namespace Rcpp; 6 | using namespace std; 7 | using namespace arma; 8 | 9 | RcppExport SEXP permudistArma(SEXP data_, SEXP groups_, SEXP rounds_); 10 | 11 | #endif /*PERMUDIST_H_*/ 12 | -------------------------------------------------------------------------------- /tests/testthat/test-CVA.r: -------------------------------------------------------------------------------- 1 | context("CVA") 2 | test_that("CVA behaves", { 3 | data(iris) 4 | vari <- iris[,1:4] 5 | facto <- iris[,5] 6 | cva.1 <- CVA(vari, groups=facto) 7 | CVA.baseline=readRDS("testdata/CVA.rds") 8 | expect_equal(abs(cva.1$CV),abs(CVA.baseline$CV),tol=0.001) 9 | }) 10 | -------------------------------------------------------------------------------- /tests/testthat/test-relWarps.r: -------------------------------------------------------------------------------- 1 | context("relative warps") 2 | test_that("relwarps behaves", { 3 | data(boneData) 4 | rW.baseline=readRDS("testdata/rW.rds") 5 | rwtest <- relWarps(boneLM) 6 | expect_equal(lapply(rwtest,abs),lapply(rW.baseline,abs),tol=1e-7) 7 | }) 8 | -------------------------------------------------------------------------------- /R/gdif.r: -------------------------------------------------------------------------------- 1 | gdif <- function (a3) 2 | { 3 | #### this is a modified copy of the function "dif" from the shapes package #### 4 | #### Copyright by Ian Dryden 5 | cc <- cSize(addo(a3)/dim(a3)[3]) 6 | x <- sweep(a3, c(1, 2), arrMean3(a3)) 7 | z <- sqrt(sum((as.vector(x)/cc)^2/dim(a3)[3])^2) 8 | 9 | return(z) 10 | } 11 | 12 | -------------------------------------------------------------------------------- /src/updateNormals.h: -------------------------------------------------------------------------------- 1 | #ifndef updateNormals_H_ 2 | #define updateNormals_H_ 3 | 4 | #include "doozers.h" 5 | 6 | using namespace Rcpp; 7 | using namespace arma; 8 | 9 | RcppExport SEXP updateVertexNormals(SEXP vb_, SEXP it_,SEXP angweight_); 10 | 11 | RcppExport SEXP updateFaceNormals(SEXP vb_, SEXP it_); 12 | 13 | 14 | #endif /*updateNormals_H_*/ 15 | -------------------------------------------------------------------------------- /R/createVarTable.r: -------------------------------------------------------------------------------- 1 | createVarTable <- function (sdev, square = TRUE, rownames=NULL) { 2 | if (square) 3 | sdev <- sdev^2 4 | sdsum <- sum(sdev) 5 | sdVar <- sdev/sdsum 6 | sdCum <- cumsum(sdVar) 7 | Variance <- data.frame(eigenvalues = sdev, exVar = sdVar, cumVar = sdCum) 8 | rownames(Variance) <- rownames 9 | return(Variance) 10 | } 11 | -------------------------------------------------------------------------------- /inst/COPYRIGHTS: -------------------------------------------------------------------------------- 1 | Files: * 2 | Copyright: Stefan Schlager 3 | License: GPL-2 4 | 5 | Some R-code was copied from subroutines of the 'shapes'-package 6 | Files: R/gdif.r 7 | parts of R/kendalldist.r [distance function for 2D configs] 8 | parts of R/rot.proc.r and R/rotonto.r [make transformation matrix rotation only (positive determinant)] 9 | Copyright: Ian Dryden 10 | License: GPL-2 11 | 12 | -------------------------------------------------------------------------------- /tests/testthat/test-pls2B.r: -------------------------------------------------------------------------------- 1 | context("2Block PLS") 2 | test_that("pls2B behaves",{ 3 | library(shapes) 4 | pls.baseline <- readRDS("testdata/pls-baseline.rds") 5 | proc <- procSym(gorf.dat) 6 | set.seed(42) 7 | pls1 <- pls2B(proc$rotated[1:4,,],proc$rotated[5:8,,],same.config=TRUE,rounds=0,mc.cores=1) 8 | expect_equal(lapply(pls1$svd,abs),lapply(pls.baseline$svd,abs),tol=0.01) 9 | }) 10 | -------------------------------------------------------------------------------- /src/doozers.h: -------------------------------------------------------------------------------- 1 | #ifndef DOOZERS_H_ 2 | #define DOOZERS_H_ 3 | #ifndef ARMA_DONT_PRINT_ERRORS 4 | #define ARMA_DONT_PRINT_ERRORS 5 | #endif 6 | 7 | #include 8 | using namespace Rcpp; 9 | using namespace arma; 10 | 11 | double angcalcArma(colvec a, colvec b); 12 | 13 | double angcalcRcpp(NumericVector a_, NumericVector b_); 14 | 15 | void crosspArma(colvec x, colvec y, colvec& z); 16 | #endif /*DOOZERS_H_*/ 17 | -------------------------------------------------------------------------------- /man/read.fcsv.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/fiducials.r 3 | \name{read.fcsv} 4 | \alias{read.fcsv} 5 | \title{read fiducials from slicer4} 6 | \usage{ 7 | read.fcsv(x, na = NULL) 8 | } 9 | \arguments{ 10 | \item{x}{filename} 11 | 12 | \item{na}{value to be replaced by NA} 13 | } 14 | \value{ 15 | a k x 3 matrix with landmarks 16 | } 17 | \description{ 18 | read fiducials from slicer4 19 | } 20 | -------------------------------------------------------------------------------- /R/difplot.lm2D.r: -------------------------------------------------------------------------------- 1 | .difplotLM2D <- function(refshape,targetshape,color=4,lwd=1,lcol=2,main=main, text=TRUE) 2 | { 3 | A <- refshape 4 | k <- dim(A)[1] 5 | m <- dim(A)[2] 6 | sds <- 0 7 | plot(refshape, col = color,main=main,asp=1,axes=FALSE,xlab="",ylab="") 8 | for (j in 1:k) 9 | lines(rbind(refshape[j,],targetshape[j,]),col=lcol,lwd=lwd) 10 | if (text) 11 | text(refshape,labels=paste("",c(1:k),sep=""),col=lcol,pos=2) 12 | } 13 | -------------------------------------------------------------------------------- /man/list2array.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/list2array.r 3 | \name{list2array} 4 | \alias{list2array} 5 | \title{converts a list of matrices to an array} 6 | \usage{ 7 | list2array(x) 8 | } 9 | \arguments{ 10 | \item{x}{a list containing matrices of the same dimensionality} 11 | } 12 | \value{ 13 | returns an array concatenating all matrices 14 | } 15 | \description{ 16 | converts a list of matrices to an array 17 | } 18 | -------------------------------------------------------------------------------- /inst/CITATION: -------------------------------------------------------------------------------- 1 | bibentry(bibtype = "InCollection", 2 | author = person("Stefan", "Schlager"), 3 | title = "Morpho and Rvcg -- Shape Analysis in {R}", 4 | booktitle = "Statistical Shape and Deformation Analysis", 5 | publisher = "Academic Press", 6 | year = 2017, 7 | editor = c(person("Guoyan", "Zheng"),person("Shuo","Li"),person("Gabor", "Szekely")), 8 | pages = "217--256", 9 | isbn = "9780128104934" 10 | ) 11 | -------------------------------------------------------------------------------- /R/eigenPCA.r: -------------------------------------------------------------------------------- 1 | eigenPCA <- function(data,tol=.Machine$double.eps) 2 | { 3 | center1 <- colMeans(data,2,mean) 4 | datascale <- scale(data,2,scale=FALSE) 5 | eigData <- eigen(cov(datascale),symmetric=TRUE) 6 | eigData$values <- eigData$values[which(eigData$values > tol)] 7 | sdev <- sqrt(eigData$values) 8 | rotation <- eigData$vectors[,1:length(sdev)] 9 | x <- t(t(rotation)%*%t(datascale)) 10 | return(list(x=x,rotation=rotation,sdev=sdev,center=center1)) 11 | } 12 | -------------------------------------------------------------------------------- /R/orp.r: -------------------------------------------------------------------------------- 1 | orp <- function(A, mshape=NULL) { 2 | p <- dim(A)[1] 3 | k <- dim(A)[2] 4 | n <- dim(A)[3] 5 | if (is.null(mshape)) 6 | mshape <- arrMean3(A) 7 | 8 | m.size <- cSize(mshape) 9 | Xc <- as.vector(mshape/m.size) 10 | X <- vecx(A)/m.size 11 | ##direction along mshape onto plane 12 | XtoPlane <- t(apply(X,1,function(x){x <- t(c(crossprod(x,Xc))*Xc)})) 13 | X1 <- X-XtoPlane 14 | X1 <- t(X1)+Xc 15 | proj <- array(X1, dim=c(p, k, n))*m.size 16 | return(proj) 17 | } 18 | -------------------------------------------------------------------------------- /man/getFaces.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/meshPlaneIntersect.r 3 | \name{getFaces} 4 | \alias{getFaces} 5 | \title{find indices of faces that contain specified vertices} 6 | \usage{ 7 | getFaces(mesh, index) 8 | } 9 | \arguments{ 10 | \item{mesh}{triangular mesh of class "mesh3d"} 11 | 12 | \item{index}{vector containing indices of vertices} 13 | } 14 | \value{ 15 | vector of face indices 16 | } 17 | \description{ 18 | find indices of faces that contain specified vertices 19 | } 20 | -------------------------------------------------------------------------------- /man/cSize.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/cSize.r 3 | \name{cSize} 4 | \alias{cSize} 5 | \title{calculate Centroid Size for a landmark configuration} 6 | \usage{ 7 | cSize(x) 8 | } 9 | \arguments{ 10 | \item{x}{k x 3 matrix containing landmark coordinates or mesh of class "mesh3d"} 11 | } 12 | \value{ 13 | returns Centroid size 14 | } 15 | \description{ 16 | calculate Centroid Size for a landmark configuration 17 | } 18 | \examples{ 19 | 20 | data(boneData) 21 | cSize(boneLM[,,1]) 22 | 23 | } 24 | -------------------------------------------------------------------------------- /R/cSize.r: -------------------------------------------------------------------------------- 1 | #' calculate Centroid Size for a landmark configuration 2 | #' 3 | #' calculate Centroid Size for a landmark configuration 4 | #' 5 | #' 6 | #' @param x k x 3 matrix containing landmark coordinates or mesh of class "mesh3d" 7 | #' @return returns Centroid size 8 | #' 9 | #' @examples 10 | #' 11 | #' data(boneData) 12 | #' cSize(boneLM[,,1]) 13 | #' 14 | #' @export 15 | cSize <- function(x){ 16 | if(inherits(x,"mesh3d")) 17 | x <- vert2points(x) 18 | X <- scale(x, scale = FALSE) 19 | y <- sqrt(sum(as.vector(X)^2)) 20 | return(y) 21 | } 22 | -------------------------------------------------------------------------------- /R/ang.r: -------------------------------------------------------------------------------- 1 | ang <- function(x,y) { 2 | if (!is.matrix(x) || !is.numeric(x)) 3 | stop("x must be a numeric matrix") 4 | if (!is.numeric(y) || length(y) != ncol(x)) 5 | stop("y must be a vector of ncol(x)") 6 | a <- .Call("ang_calcC",x,y) 7 | return(a) 8 | } 9 | angM <- function(x,y) { 10 | if (!is.matrix(x) || !is.numeric(x)) 11 | stop("x must be a numeric matrix") 12 | if (!is.matrix(y) || ncol(y) != ncol(x)) 13 | stop("y must be a matrix of same dimensionality as x") 14 | a <- .Call("ang_calcM",x,y) 15 | return(a) 16 | } 17 | -------------------------------------------------------------------------------- /R/armaGinv.r: -------------------------------------------------------------------------------- 1 | #' calculate Pseudo-inverse of a Matrix using RcppArmadillo 2 | #' 3 | #' a simple wrapper to call Armadillo's pinv function 4 | #' @param x numeric matrix 5 | #' @param tol numeric: maximum singular value to be considered 6 | #' @return Pseudo-inverse 7 | #' @examples 8 | #' mat <- matrix(rnorm(12),3,4) 9 | #' pinvmat <- armaGinv(mat) 10 | #' @export 11 | armaGinv <- function(x, tol=NULL) 12 | { 13 | if (!is.matrix(x) || !is.numeric(x)) 14 | stop("input must be a matrix") 15 | out <- .Call("armaGinvCpp", x ,tol) 16 | return(out) 17 | } 18 | -------------------------------------------------------------------------------- /man/armaGinv.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/armaGinv.r 3 | \name{armaGinv} 4 | \alias{armaGinv} 5 | \title{calculate Pseudo-inverse of a Matrix using RcppArmadillo} 6 | \usage{ 7 | armaGinv(x, tol = NULL) 8 | } 9 | \arguments{ 10 | \item{x}{numeric matrix} 11 | 12 | \item{tol}{numeric: maximum singular value to be considered} 13 | } 14 | \value{ 15 | Pseudo-inverse 16 | } 17 | \description{ 18 | a simple wrapper to call Armadillo's pinv function 19 | } 20 | \examples{ 21 | mat <- matrix(rnorm(12),3,4) 22 | pinvmat <- armaGinv(mat) 23 | } 24 | -------------------------------------------------------------------------------- /man/mesh2grey.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/mesh2grey.r 3 | \name{mesh2grey} 4 | \alias{mesh2grey} 5 | \title{convert a colored mesh to greyscale.} 6 | \usage{ 7 | mesh2grey(mesh) 8 | } 9 | \arguments{ 10 | \item{mesh}{Object of class mesh3d} 11 | } 12 | \value{ 13 | returns a mesh with material$color replaced by greyscale rgb values. 14 | } 15 | \description{ 16 | convert the colors of a colored mesh to greyscale values 17 | } 18 | \seealso{ 19 | \code{\link{ply2mesh}},\code{\link{file2mesh}} 20 | } 21 | \author{ 22 | Stefan Schlager 23 | } 24 | -------------------------------------------------------------------------------- /R/mesh2obj.r: -------------------------------------------------------------------------------- 1 | #' @rdname mesh2ply 2 | #' @export 3 | mesh2obj <- function(x,filename=dataname) 4 | { 5 | ismatrix <- FALSE 6 | x.it <- NULL 7 | dataname <- deparse(substitute(x)) 8 | if (is.matrix(x)) { 9 | ismatrix <- TRUE 10 | dimsx <- dim(x) 11 | if (dimsx[2] == 3 && dimsx[1] != 3) 12 | x <- t(x) 13 | x <- list(vb=x) 14 | } 15 | x.vb <- cbind("v",t(x$vb[1:3,])) 16 | if (! ismatrix) 17 | x.it <- cbind("f",t(x$it)) 18 | obj <- rbind(x.vb,x.it) 19 | 20 | write.obj(obj, filename=filename) 21 | } 22 | 23 | -------------------------------------------------------------------------------- /man/colors.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/Morpho-package.R 3 | \docType{data} 4 | \name{colors} 5 | \alias{colors} 6 | \alias{bone1} 7 | \alias{bone2} 8 | \alias{bone3} 9 | \alias{skin1} 10 | \alias{skin2} 11 | \alias{skin3} 12 | \alias{skin4} 13 | \title{predefined colors for bone and skin} 14 | \description{ 15 | predefined colors for bone and skin 16 | } 17 | \details{ 18 | available colors are: 19 | 20 | bone1 21 | 22 | bone2 23 | 24 | bone3 25 | 26 | skin1 27 | 28 | skin2 29 | 30 | skin3 31 | 32 | skin4 33 | } 34 | \keyword{datasets} 35 | -------------------------------------------------------------------------------- /man/getTrafo4x4.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/rotonto.r 3 | \name{getTrafo4x4} 4 | \alias{getTrafo4x4} 5 | \alias{getTrafo4x4.rotonto} 6 | \title{get 4x4 Transformation matrix} 7 | \usage{ 8 | getTrafo4x4(x) 9 | 10 | \method{getTrafo4x4}{rotonto}(x) 11 | } 12 | \arguments{ 13 | \item{x}{object of class "rotonto"} 14 | } 15 | \value{ 16 | returns a 4x4 transformation matrix 17 | } 18 | \description{ 19 | get 4x4 Transformation matrix 20 | } 21 | \examples{ 22 | data(boneData) 23 | rot <- rotonto(boneLM[,,1],boneLM[,,2]) 24 | trafo <- getTrafo4x4(rot) 25 | } 26 | -------------------------------------------------------------------------------- /src/barycenter.cpp: -------------------------------------------------------------------------------- 1 | #include 2 | 3 | using namespace Rcpp; 4 | using namespace std; 5 | //using namespace arma; 6 | 7 | RcppExport SEXP barycenterCpp(SEXP vb_, SEXP it_) { 8 | try { 9 | NumericMatrix vb(vb_); 10 | IntegerMatrix it(it_); 11 | int nit = it.ncol(); 12 | NumericMatrix bary(nit,3); 13 | for (int i=0; i < nit; ++i) { 14 | bary(i,_) = (vb(_,it(0,i))+vb(_,it(1,i))+vb(_,it(2,i)))/3; 15 | } 16 | return wrap(bary); 17 | } catch (std::exception& e) { 18 | ::Rf_error( e.what()); 19 | } catch (...) { 20 | ::Rf_error("unknown exception"); 21 | } 22 | } 23 | -------------------------------------------------------------------------------- /src/addCube.h: -------------------------------------------------------------------------------- 1 | #ifndef ADDCUBE_H_ 2 | #define ADDCUBE_H_ 3 | #include 4 | #include "doozers.h" 5 | 6 | using namespace Rcpp; 7 | using namespace std; 8 | using namespace arma; 9 | 10 | namespace Morpho 11 | { 12 | template 13 | class IOCube 14 | { 15 | public: 16 | static Mat addCube(Cube mycube) { 17 | int n = mycube.n_slices; 18 | Mat out = mycube.slice(0); 19 | if (n > 1) { 20 | for (int i=1; i < n; i++) { 21 | out += mycube.slice(i); 22 | } 23 | } 24 | return out; 25 | } 26 | }; 27 | } 28 | #endif /*ADDCUBE_H_*/ 29 | -------------------------------------------------------------------------------- /man/areaSphere.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/angleTest.r 3 | \name{areaSphere} 4 | \alias{areaSphere} 5 | \title{compute the area of an n-dimensional hypersphere} 6 | \usage{ 7 | areaSphere(n, r = 1) 8 | } 9 | \arguments{ 10 | \item{n}{dimensionality of space the hypersphere is embedded in (e.g.3 for a 3D-sphere)} 11 | 12 | \item{r}{radius of the sphere} 13 | } 14 | \value{ 15 | returns the area 16 | } 17 | \description{ 18 | compute the area of an n-dimensional hypersphere 19 | } 20 | \examples{ 21 | areaSphere(2) #gives us the circumference of a circle of radius 1 22 | } 23 | -------------------------------------------------------------------------------- /man/boneData.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/Morpho-package.R 3 | \docType{data} 4 | \name{boneData} 5 | \alias{boneData} 6 | \alias{boneLM} 7 | \alias{skull_0144_ch_fe.mesh} 8 | \title{Landmarks and a triangular mesh} 9 | \format{\code{boneLM}: A 10x3x80 array containing 80 sets of 3D-landmarks 10 | placed on the human osseous nose. 11 | 12 | \code{skull_0144_ch_fe.mesh}: The mesh representing the area of the first 13 | individual of \code{boneLM}} 14 | \description{ 15 | Landmarks on the osseous human nose and a triangular mesh representing this 16 | structure. 17 | } 18 | \keyword{datasets} 19 | -------------------------------------------------------------------------------- /man/meshres.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/meshres.r 3 | \name{meshres} 4 | \alias{meshres} 5 | \title{calculate average edge length of a triangular mesh} 6 | \usage{ 7 | meshres(mesh) 8 | } 9 | \arguments{ 10 | \item{mesh}{triangular mesh stored as object of class "mesh3d"} 11 | } 12 | \value{ 13 | returns average edge length (a.k.a. mesh resolution) 14 | } 15 | \description{ 16 | calculate average edge length of a triangular mesh, by iterating over all 17 | faces. 18 | } 19 | \examples{ 20 | 21 | data(boneData) 22 | mres <- meshres(skull_0144_ch_fe.mesh) 23 | 24 | 25 | } 26 | \author{ 27 | Stefan Schlager 28 | } 29 | -------------------------------------------------------------------------------- /man/meshcube.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/meshcube.r 3 | \name{meshcube} 4 | \alias{meshcube} 5 | \title{calculate the corners of a mesh's bouning box} 6 | \usage{ 7 | meshcube(x) 8 | } 9 | \arguments{ 10 | \item{x}{object of class 'mesh3d'} 11 | } 12 | \value{ 13 | returns a 8 x 3 matrix with the coordinates of the corners of the 14 | bounding box. 15 | } 16 | \description{ 17 | calculate the corners of a mesh's bouning box 18 | } 19 | \examples{ 20 | 21 | require(rgl) 22 | data(boneData) 23 | mc <- meshcube(skull_0144_ch_fe.mesh) 24 | \dontrun{ 25 | spheres3d(mc) 26 | wire3d(skull_0144_ch_fe.mesh) 27 | } 28 | 29 | } 30 | -------------------------------------------------------------------------------- /man/write.fcsv.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/fiducials.r 3 | \name{write.fcsv} 4 | \alias{write.fcsv} 5 | \title{write fiducials in slicer4 format} 6 | \usage{ 7 | write.fcsv(x, filename = dataname, description = NULL) 8 | } 9 | \arguments{ 10 | \item{x}{matrix with row containing 2D or 3D coordinates} 11 | 12 | \item{filename}{will be substituted with ".fcsv"} 13 | 14 | \item{description}{optional: character vector containing a description for each landmark} 15 | } 16 | \description{ 17 | write fiducials in slicer4 format 18 | } 19 | \examples{ 20 | require(Rvcg) 21 | data(dummyhead) 22 | write.fcsv(dummyhead.lm) 23 | } 24 | -------------------------------------------------------------------------------- /R/meshcube.r: -------------------------------------------------------------------------------- 1 | #' calculate the corners of a mesh's bouning box 2 | #' 3 | #' calculate the corners of a mesh's bouning box 4 | #' 5 | #' 6 | #' @param x object of class 'mesh3d' 7 | #' @return returns a 8 x 3 matrix with the coordinates of the corners of the 8 | #' bounding box. 9 | #' 10 | #' @examples 11 | #' 12 | #' require(rgl) 13 | #' data(boneData) 14 | #' mc <- meshcube(skull_0144_ch_fe.mesh) 15 | #' \dontrun{ 16 | #' spheres3d(mc) 17 | #' wire3d(skull_0144_ch_fe.mesh) 18 | #' } 19 | #' 20 | #' @export 21 | meshcube <- function(x) 22 | { 23 | bbox <- apply(vert2points(x), 2, range) 24 | bbox <- expand.grid(bbox[, 1], bbox[, 2], bbox[, 3]) 25 | return(bbox) 26 | } 27 | -------------------------------------------------------------------------------- /src/armaGinvCpp.cpp: -------------------------------------------------------------------------------- 1 | #include "armaGinvCpp.h" 2 | 3 | SEXP armaGinvCpp(SEXP matIn_, SEXP tol_) { 4 | try { 5 | if (!Rf_isMatrix(matIn_)){ 6 | return wrap(1); 7 | } else { 8 | mat matA = as(matIn_); 9 | mat invA; 10 | bool check; 11 | if (Rf_isNumeric(tol_)) { 12 | double tol = as(tol_); 13 | check =pinv(invA, matA, tol); 14 | } else { 15 | check = pinv(invA, matA); 16 | } 17 | if (check) 18 | return wrap(invA); 19 | else 20 | return wrap(1); 21 | 22 | } 23 | } catch (std::exception& e) { 24 | ::Rf_error( e.what()); 25 | } catch (...) { 26 | ::Rf_error("unknown exception"); 27 | } 28 | } 29 | -------------------------------------------------------------------------------- /src/covPCA.h: -------------------------------------------------------------------------------- 1 | #ifndef _covPCA_H 2 | #define _covPCA_H 3 | #ifndef ARMA_DONT_PRINT_ERRORS 4 | #define ARMA_DONT_PRINT_ERRORS 5 | #include 6 | #endif 7 | 8 | using namespace Rcpp; 9 | using namespace std; 10 | using namespace arma; 11 | 12 | double covDist(mat &s1, mat &s2); 13 | 14 | mat covDistMulti(mat &data, ivec groups, bool scramble); 15 | 16 | cube covPCAboot(mat &data, ivec groups, int rounds); 17 | 18 | cube covPCApermute(mat &data, ivec groups, int rounds); 19 | 20 | List covMDS(mat &dists); 21 | 22 | RcppExport SEXP covPCAwrap(SEXP data_, SEXP groups_, SEXP scramble_, SEXP rounds_); 23 | 24 | RcppExport SEXP covWrap(SEXP s1_, SEXP s2_); 25 | 26 | #endif 27 | -------------------------------------------------------------------------------- /man/arrMean3.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/addo.r 3 | \name{arrMean3} 4 | \alias{arrMean3} 5 | \title{calculate mean of an array} 6 | \usage{ 7 | arrMean3(arr) 8 | } 9 | \arguments{ 10 | \item{arr}{\code{k x m x n} dimensional numeric array} 11 | } 12 | \value{ 13 | matrix of dimensions \code{k x m}. 14 | } 15 | \description{ 16 | calculate mean of a 3D-array (e.g. containing landmarks) (fast) using the Armadillo C++ Backend 17 | } 18 | \note{ 19 | this is the same as \code{apply(arr, 1:2, mean)}, only faster for large configurations. 20 | } 21 | \examples{ 22 | data(boneData) 23 | proc <- ProcGPA(boneLM, silent = TRUE) 24 | mshape <- arrMean3(proc$rotated) 25 | } 26 | -------------------------------------------------------------------------------- /R/difplot.lm.r: -------------------------------------------------------------------------------- 1 | .difplotLM <- function(refshape,targetshape,color=4,lwd=1,lcol=2,rgl.new=TRUE, text=TRUE) 2 | { 3 | if (rgl.new == TRUE) 4 | open3d() 5 | 6 | A <- refshape 7 | k <- dim(A)[1] 8 | m <- dim(A)[2] 9 | sds <- 0 10 | lim <- max(abs(refshape)) 11 | sz <- (cSize(refshape)/sqrt(k))*(1/80) 12 | spheres3d(refshape, col = color,radius=sz) 13 | linemesh <- list() 14 | linemesh$vb <- t(cbind(rbind(refshape,targetshape),1)) 15 | linemesh$it <- t(cbind(1:k,1:k,(1:k)+k)) 16 | class(linemesh) <- "mesh3d" 17 | wire3d(linemesh,col=lcol,lwd=lwd,lit=F) 18 | if (text) 19 | text3d(refshape,texts=paste("",c(1:k),sep=""),cex=1,col=lcol,adj=1.2) 20 | } 21 | -------------------------------------------------------------------------------- /man/kendalldist.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/kendalldist.r 3 | \name{kendalldist} 4 | \alias{kendalldist} 5 | \title{Calculates the Riemannian distance between two superimposed landmark 6 | configs.} 7 | \usage{ 8 | kendalldist(x, y) 9 | } 10 | \arguments{ 11 | \item{x}{Matrix containing landmark coordinates.} 12 | 13 | \item{y}{Matrix containing landmark coordinates.} 14 | } 15 | \value{ 16 | returns Riemannian distance 17 | } 18 | \description{ 19 | Calculates the Riemannian distance between two superimposed landmark 20 | configs. 21 | } 22 | \examples{ 23 | if(require(shapes)) { 24 | OPA <- rotonto(gorf.dat[,,1],gorf.dat[,,2]) 25 | kendalldist(OPA$X,OPA$Y) 26 | } 27 | } 28 | -------------------------------------------------------------------------------- /man/areaSpherePart.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/angleTest.r 3 | \name{areaSpherePart} 4 | \alias{areaSpherePart} 5 | \title{compute the area of an n-dimensional hypersphere cap} 6 | \usage{ 7 | areaSpherePart(n, phi, r = 1) 8 | } 9 | \arguments{ 10 | \item{n}{dimensionality of space the hypersphere is embedded in (e.g.3 for a 3D-sphere)} 11 | 12 | \item{phi}{angle between vectors defining the cone} 13 | 14 | \item{r}{radius of the sphere} 15 | } 16 | \value{ 17 | returns the area of the hypersphere cap 18 | } 19 | \description{ 20 | compute the area of an n-dimensional hypersphere cap 21 | } 22 | \examples{ 23 | areaSpherePart(2,pi/2) # covers half the area of a circle 24 | } 25 | -------------------------------------------------------------------------------- /man/nose.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/Morpho-package.R 3 | \docType{data} 4 | \name{nose} 5 | \alias{nose} 6 | \alias{shortnose.mesh} 7 | \alias{shortnose.lm} 8 | \alias{longnose.lm} 9 | \title{landmarks and a triangular mesh representing a human nose} 10 | \format{\code{shortnose.mesh}: A triangular mesh of class 'mesh3d'. 11 | 12 | \code{shortnose.lm}: matrix containing example landmark data placed on 13 | \code{shortnose.mesh}. 14 | 15 | \code{longnose.lm}: matrix containing example landmark data representing a 16 | caricaturesquely deformed human nose.} 17 | \description{ 18 | triangular mesh representing a human nose and two matrices containing 19 | landmark data 20 | } 21 | \keyword{datasets} 22 | -------------------------------------------------------------------------------- /src/points2mesh.h: -------------------------------------------------------------------------------- 1 | #ifndef POINTS_2_MESH_H_ 2 | #define POINTS_2_MESH_H_ 3 | 4 | #include 5 | #include 6 | #include "doozers.h" 7 | 8 | 9 | using namespace Rcpp; 10 | using namespace arma; 11 | 12 | mat updateSearchStruct(mat vb, umat it, uvec clostInd); 13 | 14 | double pt_triangle(vec point, vec vbtmp, vec& clost, int& region); 15 | 16 | double pt_triplane(vec point, vec vbtmp, vec& clost); 17 | 18 | vec pt2mesh(vec point, mat DAT, double& dist, int& faceptr, int& region, int method); 19 | 20 | vec getBaryCent(vec point, int fptr, mat vb, umat it); 21 | 22 | RcppExport SEXP points2mesh(SEXP ref_,SEXP vb_, SEXP it_, SEXP normals_, SEXP clostInd_, SEXP sign_, SEXP bary_, SEXP method_); 23 | 24 | #endif /*POINTS_2_MESH_H_*/ 25 | -------------------------------------------------------------------------------- /src/face_zero.cpp: -------------------------------------------------------------------------------- 1 | #include 2 | 3 | using namespace Rcpp; 4 | using namespace std; 5 | 6 | RcppExport SEXP face_zero(SEXP it_) { 7 | try { 8 | IntegerMatrix it(it_); 9 | int nit = it.ncol(); 10 | IntegerVector out(nit); 11 | for (int i=0; i < nit; i++) { 12 | if (it(0,i) == 0 || it(1,i) == 0 || it(2,i) == 0) 13 | out(i) = 0; 14 | else 15 | out(i) = 1; 16 | //IntegerVector tmp = it(_,i); 17 | //out(i) = std::accumulate(tmp.begin(), tmp.end(), 1,std::multiplies()); 18 | //Rprintf("%i\n",a); 19 | //out(i) = a; 20 | } 21 | return wrap(out); 22 | } catch (std::exception& e) { 23 | ::Rf_error( e.what()); 24 | } catch (...) { 25 | ::Rf_error("unknown exception"); 26 | } 27 | } 28 | -------------------------------------------------------------------------------- /man/rotaxisMat.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/rotaxis.r 3 | \name{rotaxisMat} 4 | \alias{rotaxisMat} 5 | \title{calculate a rotation matrix around an arbitrary axis through the origin in 6 | 3D} 7 | \usage{ 8 | rotaxisMat(u, theta, homogeneous = FALSE) 9 | } 10 | \arguments{ 11 | \item{u}{a vector around which to rotate} 12 | 13 | \item{theta}{angle in radians to rotate} 14 | 15 | \item{homogeneous}{logical: if TRUE a 4x4 rotation matrix is returned} 16 | } 17 | \value{ 18 | returns 3x3 rotation matrix 19 | } 20 | \description{ 21 | calculate a rotation matrix around an arbitrary axis in 3D 22 | } 23 | \references{ 24 | http://en.wikipedia.org/wiki/Rotation_matrix 25 | } 26 | \seealso{ 27 | \code{\link{rotaxis3d}} 28 | } 29 | -------------------------------------------------------------------------------- /R/conv2backf.r: -------------------------------------------------------------------------------- 1 | #' invert faces' orientation of triangular mesh 2 | #' 3 | #' inverts faces' orientation of triangular mesh and recomputes vertex normals 4 | #' 5 | #' 6 | #' @param mesh triangular mesh of class \code{mesh3d} 7 | #' @return returns resulting mesh 8 | #' @author Stefan Schlager 9 | #' @seealso \code{\link{updateNormals}} 10 | #' 11 | #' @examples 12 | #' 13 | #' 14 | #' data(nose) 15 | #' \dontrun{ 16 | #' rgl::shade3d(shortnose.mesh,col=3) 17 | #' } 18 | #' noseinvert <- invertFaces(shortnose.mesh) 19 | #' ## show normals 20 | #' \dontrun{ 21 | #' plotNormals(noseinvert,long=0.01) 22 | #' } 23 | #' @export 24 | invertFaces <- function(mesh) 25 | { 26 | mesh$it <- mesh$it[c(3,2,1),,drop=F] 27 | mesh <- vcgUpdateNormals(mesh) 28 | return(mesh) 29 | } 30 | -------------------------------------------------------------------------------- /man/Morpho-deprecated.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/Morpho-package.R 3 | \name{deprecated} 4 | \alias{deprecated} 5 | \alias{deform.grid} 6 | \alias{adnormals} 7 | \alias{regdist.raw} 8 | \alias{crossp} 9 | \alias{tanplan} 10 | \alias{conv2backf} 11 | \alias{warp.mesh} 12 | \title{deprecated functions of Morpho} 13 | \usage{ 14 | deform.grid(...) 15 | 16 | adnormals(...) 17 | 18 | regdist.raw(dataarray, plot = TRUE, main = "", rho = "angle", 19 | dist.mat.out = FALSE) 20 | 21 | crossp(...) 22 | 23 | tanplan(...) 24 | 25 | conv2backf(...) 26 | 27 | warp.mesh(mesh, matr, matt, lambda = 1e-08, updateNormals = TRUE, 28 | silent = FALSE) 29 | } 30 | \description{ 31 | document deprecated functions 32 | } 33 | \keyword{internal} 34 | -------------------------------------------------------------------------------- /man/angle.calc.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/angle.calc.r 3 | \name{angle.calc} 4 | \alias{angle.calc} 5 | \title{calculate angle between two vectors} 6 | \usage{ 7 | angle.calc(x, y) 8 | } 9 | \arguments{ 10 | \item{x}{numeric vector (or matrix to be interpreted as vector)} 11 | 12 | \item{y}{numeric vector (or matrix to be interpreted as vector) of same 13 | length as \code{x}} 14 | } 15 | \value{ 16 | angle between x and y in radians. 17 | } 18 | \description{ 19 | calculates unsigned angle between two vectors 20 | } 21 | \examples{ 22 | 23 | #calculate angle between two centered and 24 | # superimposed landmark configuration 25 | data(boneData) 26 | opa <- rotonto(boneLM[,,1],boneLM[,,2]) 27 | angle.calc(opa$X, opa$Y) 28 | 29 | } 30 | -------------------------------------------------------------------------------- /R/angle.calc.r: -------------------------------------------------------------------------------- 1 | #' calculate angle between two vectors 2 | #' 3 | #' calculates unsigned angle between two vectors 4 | #' 5 | #' 6 | #' @param x numeric vector (or matrix to be interpreted as vector) 7 | #' @param y numeric vector (or matrix to be interpreted as vector) of same 8 | #' length as \code{x} 9 | #' @return angle between x and y in radians. 10 | #' 11 | #' @examples 12 | #' 13 | #' #calculate angle between two centered and 14 | #' # superimposed landmark configuration 15 | #' data(boneData) 16 | #' opa <- rotonto(boneLM[,,1],boneLM[,,2]) 17 | #' angle.calc(opa$X, opa$Y) 18 | #' 19 | #' @export 20 | angle.calc <- function(x,y) 21 | { x <- as.vector(x)/sqrt(sum(x^2)) 22 | y <- as.vector(y)/sqrt(sum(y^2)) 23 | rho <- acos((sum((x-y)^2)-2)/-2) 24 | return(rho) 25 | } 26 | -------------------------------------------------------------------------------- /man/getPLSscores.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/pls2B.r 3 | \name{getPLSscores} 4 | \alias{getPLSscores} 5 | \title{compute 2-Block PLS scores for new data} 6 | \usage{ 7 | getPLSscores(pls, x, y) 8 | } 9 | \arguments{ 10 | \item{pls}{output of pls2B} 11 | 12 | \item{x}{matrix or vector representing new dataset(s) - same kind as in original pls2B} 13 | 14 | \item{y}{matrix or vector representing new dataset(s) - same kind as in original pls2B} 15 | } 16 | \value{ 17 | returns a vector of pls-scores 18 | } 19 | \description{ 20 | compute 2-Block PLS scores for new data from an existing pls2B 21 | } 22 | \note{ 23 | either x or y must be missing 24 | } 25 | \seealso{ 26 | \code{\link{pls2B}, \link{predictPLSfromScores},\link{predictPLSfromData}} 27 | } 28 | -------------------------------------------------------------------------------- /R/calcGamma.r: -------------------------------------------------------------------------------- 1 | #' @importFrom Matrix forceSymmetric tcrossprod 2 | calcGamma <- function(Gamma0,Lsubk3,U,dims,stepsize=1) 3 | { 4 | 5 | U <- as(U,"sparseMatrix") 6 | tUL <- crossprod(U,Lsubk3) 7 | ULU <- forceSymmetric(tUL%*%U) 8 | B <- tUL%*%Gamma0 9 | B <- as(B,"sparseMatrix") 10 | T <- solve(ULU,B) 11 | ULUT <- U%*%T 12 | Gamma0 <- Gamma0-stepsize*ULUT 13 | Gamma0 <- matrix(Gamma0,length(Gamma0)/dims,dims) 14 | return(Gamma0) 15 | } 16 | 17 | calcProcDGamma <- function(U,Gamma0,mshape,dims,stepsize=1) { 18 | Tpart <- tcrossprod(U) 19 | mshape <- as.vector(mshape) 20 | tmpdiff <- Gamma0-mshape 21 | slided <- Gamma0-stepsize*(Tpart%*%tmpdiff) 22 | slided <- matrix(slided,length(slided)/dims,dims) 23 | return(slided) 24 | } 25 | -------------------------------------------------------------------------------- /man/invertFaces.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/conv2backf.r 3 | \name{invertFaces} 4 | \alias{invertFaces} 5 | \title{invert faces' orientation of triangular mesh} 6 | \usage{ 7 | invertFaces(mesh) 8 | } 9 | \arguments{ 10 | \item{mesh}{triangular mesh of class \code{mesh3d}} 11 | } 12 | \value{ 13 | returns resulting mesh 14 | } 15 | \description{ 16 | inverts faces' orientation of triangular mesh and recomputes vertex normals 17 | } 18 | \examples{ 19 | 20 | 21 | data(nose) 22 | \dontrun{ 23 | rgl::shade3d(shortnose.mesh,col=3) 24 | } 25 | noseinvert <- invertFaces(shortnose.mesh) 26 | ## show normals 27 | \dontrun{ 28 | plotNormals(noseinvert,long=0.01) 29 | } 30 | } 31 | \seealso{ 32 | \code{\link{updateNormals}} 33 | } 34 | \author{ 35 | Stefan Schlager 36 | } 37 | -------------------------------------------------------------------------------- /man/read.lmdta.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/read.lmdta.r 3 | \name{read.lmdta} 4 | \alias{read.lmdta} 5 | \title{read dta files} 6 | \usage{ 7 | read.lmdta(file = "x", na = 9999) 8 | } 9 | \arguments{ 10 | \item{file}{a dta file} 11 | 12 | \item{na}{specifies a value that indicates missing values} 13 | } 14 | \value{ 15 | \item{arr }{array containing landmarks dimnames will be Information of 16 | ID and landmark names specified in Landmark} 17 | \item{info }{Information extracted from the header of the dta file} 18 | \item{idnames }{character vector containing the names of the individuals 19 | as specified in the dta file} 20 | } 21 | \description{ 22 | reads .dta files created by the software Landmark 23 | http://graphics.idav.ucdavis.edu/research/EvoMorph 24 | } 25 | -------------------------------------------------------------------------------- /R/list2array.r: -------------------------------------------------------------------------------- 1 | #' converts a list of matrices to an array 2 | #' 3 | #' converts a list of matrices to an array 4 | #' @param x a list containing matrices of the same dimensionality 5 | #' @return returns an array concatenating all matrices 6 | #' @export 7 | list2array <- function(x) { 8 | xclass <- sapply(x,class) 9 | classchk <- prod(xclass == "matrix") 10 | if (!classchk) 11 | stop("all list entries must be matrices") 12 | xdim <- sapply(x,dim) 13 | dimchk <- prod(xdim[1,] == xdim[1,1])*prod(xdim[2,] == xdim[2,1]) 14 | if (!dimchk) 15 | stop("all list entries must have the same dimensions") 16 | 17 | arr <- array(0,dim=c(dim(x[[1]]),length(x))) 18 | dimnames(arr)[[3]] <- names(x) 19 | for (i in 1:length(x)) 20 | arr[,,i] <- x[[i]] 21 | return(arr) 22 | } 23 | -------------------------------------------------------------------------------- /man/read.pts.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/read.pts.r 3 | \name{read.pts} 4 | \alias{read.pts} 5 | \title{reads pts files} 6 | \usage{ 7 | read.pts(file = "x", na = 9999) 8 | } 9 | \arguments{ 10 | \item{file}{pts file} 11 | 12 | \item{na}{specifies a value that indicates missing values} 13 | } 14 | \value{ 15 | \item{matrix }{matrix containing landmark information rownames will be 16 | the names given to the landmarks in Landmark} 17 | } 18 | \description{ 19 | reads Landmark data exported from the software Landmark from 20 | http://graphics.idav.ucdavis.edu/research/EvoMorph 21 | } 22 | \examples{ 23 | 24 | data(nose) 25 | write.pts(shortnose.lm, filename="shortnose") 26 | data <- read.pts("shortnose.pts") 27 | 28 | } 29 | \seealso{ 30 | \code{\link{read.pts}} 31 | } 32 | -------------------------------------------------------------------------------- /man/getTrafoRotaxis.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/rotaxis.r 3 | \name{getTrafoRotaxis} 4 | \alias{getTrafoRotaxis} 5 | \title{compute a 4x4 Transformation matrix for rotation around an arbitrary axis} 6 | \usage{ 7 | getTrafoRotaxis(pt1, pt2, theta) 8 | } 9 | \arguments{ 10 | \item{pt1}{numeric vector of length 3, defining first point on the rotation 11 | axis.} 12 | 13 | \item{pt2}{numeric vector of length 3, defining second point on the rotation 14 | axis.} 15 | 16 | \item{theta}{angle to rotate in radians. With pt1 being the viewpoint, the 17 | rotation is counterclockwise.} 18 | } 19 | \description{ 20 | compute a 4x4 Transformation matrix for rotation around an arbitrary axis 21 | } 22 | \note{ 23 | the resulting matrix can be used in \code{\link{applyTransform}} 24 | } 25 | -------------------------------------------------------------------------------- /tests/testthat/test-slider3d.r: -------------------------------------------------------------------------------- 1 | context("sliding semilandmarks") 2 | test_that("relwarps behaves", { 3 | data(boneData) 4 | slider.baseline=readRDS("testdata/slider3d.rds") 5 | data(nose) 6 | longnose.mesh <- tps3d(shortnose.mesh,shortnose.lm,longnose.lm,threads=1) 7 | meshlist <- list(shortnose.mesh,longnose.mesh) 8 | data <- bindArr(shortnose.lm, longnose.lm, along=3) 9 | dimnames(data)[[3]] <- c("shortnose", "longnose") 10 | fix <- c(1:5,20:21) 11 | surp <- c(1:nrow(shortnose.lm))[-fix] 12 | slide <- slider3d(data, SMvector=fix, deselect=TRUE,meshlist=meshlist,surp=surp,iterations=1,mc.cores=1,fixRepro=FALSE)$dataslide 13 | expect_equal(slide,slider.baseline,tol=0.01) 14 | }) 15 | -------------------------------------------------------------------------------- /man/line2plane.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/line2plane.r 3 | \name{line2plane} 4 | \alias{line2plane} 5 | \title{get intersection between a line and a plane} 6 | \usage{ 7 | line2plane(ptLine, ptDir, planePt, planeNorm) 8 | } 9 | \arguments{ 10 | \item{ptLine}{vector of length 3: point on line} 11 | 12 | \item{ptDir}{vector of length 3: direction vector of line} 13 | 14 | \item{planePt}{vector of length 3: point on plane} 15 | 16 | \item{planeNorm}{vector of length 3: plane normal vector} 17 | } 18 | \value{ 19 | hit point 20 | } 21 | \description{ 22 | get intersection between a line and a plane 23 | } 24 | \note{ 25 | in case you only have three points on a plane (named \code{pt1, pt2, pt3} you can get the plane's normal by calling \code{crossProduct(pt1-pt2,pt1-pt3)}. 26 | } 27 | -------------------------------------------------------------------------------- /R/createMissingList.r: -------------------------------------------------------------------------------- 1 | #' create a list with empty entries to be used as missingList in slider3d 2 | #' 3 | #' create a list with empty entries to be used as missingList in slider3d 4 | #' 5 | #' @param x length of the list to be created 6 | #' @return returns a list of length \code{x} filled with numerics of length zero. 7 | #' @examples 8 | #' ## Assume in a sample of 10, the 9th individual has (semi-)landmarks 10:50 9 | #' # hanging in thin air (e.g. estimated using fixLMtps) 10 | #' # while the others are complete. 11 | #' ## create empty list 12 | #' missingList <- createMissingList(10) 13 | #' missingList[[9]] <- 10:50 14 | #' @seealso \code{\link{fixLMtps},\link{fixLMmirror}, \link{slider3d}} 15 | #' @export 16 | createMissingList <- function(x) { 17 | ml <- lapply(1:x,function(x) x <- numeric(0)) 18 | return(ml) 19 | } 20 | -------------------------------------------------------------------------------- /man/read.mpp.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/read.mpp.r 3 | \name{read.mpp} 4 | \alias{read.mpp} 5 | \title{Read saved pick-points from meshlab} 6 | \usage{ 7 | read.mpp(file, info = FALSE) 8 | } 9 | \arguments{ 10 | \item{file}{file to import} 11 | 12 | \item{info}{logical: if TRUE, addtional infos are returned} 13 | } 14 | \value{ 15 | if \code{info=FALSE}: 16 | 17 | a matrix containing picked-points coordinates (only those tagged as active). 18 | 19 | if \code{info=TRUE}: a list containing 20 | \item{data }{matrix containing coordinates - including points tagged as inactive} 21 | \item{info }{additional info contained in file.} 22 | } 23 | \description{ 24 | imports pick points selected with meshlab 25 | } 26 | \seealso{ 27 | \code{\link{read.pts}} 28 | } 29 | \author{ 30 | Stefan Schlager 31 | } 32 | -------------------------------------------------------------------------------- /man/plotNormals.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/plot.normals.r 3 | \name{plotNormals} 4 | \alias{plotNormals} 5 | \title{plots the normals of a triangular surface mesh.} 6 | \usage{ 7 | plotNormals(x, long = 1, lwd = 1, col = 1) 8 | } 9 | \arguments{ 10 | \item{x}{object of class "mesh3d"} 11 | 12 | \item{long}{length of the normals (default is 1)} 13 | 14 | \item{lwd}{width of the normals} 15 | 16 | \item{col}{color of the normals} 17 | } 18 | \description{ 19 | visualises the vertex normals of a triangular surface mesh of class mesh3d. 20 | If no normals are contained, they are computed. 21 | } 22 | \examples{ 23 | 24 | \dontrun{ 25 | require(rgl) 26 | data(nose) 27 | plotNormals(shortnose.mesh,col=4,long=0.01) 28 | shade3d(shortnose.mesh,col=3) 29 | } 30 | 31 | } 32 | \author{ 33 | Stefan Schlager 34 | } 35 | -------------------------------------------------------------------------------- /man/getPLSfromScores.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/pls2B.r 3 | \name{getPLSfromScores} 4 | \alias{getPLSfromScores} 5 | \title{compute changes associated with 2-Block PLS-scores} 6 | \usage{ 7 | getPLSfromScores(pls, x, y) 8 | } 9 | \arguments{ 10 | \item{pls}{output of pls2B} 11 | 12 | \item{x}{scores associated with dataset x in original pls2B} 13 | 14 | \item{y}{scores associated with dataset y in original pls2B} 15 | } 16 | \value{ 17 | returns data in the original space associated with the specified values. 18 | } 19 | \description{ 20 | compute changes associated with 2-Block PLS-scores 21 | } 22 | \details{ 23 | other than \code{\link{predictPLSfromScores}}, providing Xscores will not compute predictions of y, but the changes in the original data \code{x} that is associated with the specific scores 24 | } 25 | -------------------------------------------------------------------------------- /R/line2plane.r: -------------------------------------------------------------------------------- 1 | #' get intersection between a line and a plane 2 | #' 3 | #' get intersection between a line and a plane 4 | #' @param ptLine vector of length 3: point on line 5 | #' @param ptDir vector of length 3: direction vector of line 6 | #' @param planeNorm vector of length 3: plane normal vector 7 | #' @param planePt vector of length 3: point on plane 8 | #' @return hit point 9 | #' @note in case you only have three points on a plane (named \code{pt1, pt2, pt3} you can get the plane's normal by calling \code{crossProduct(pt1-pt2,pt1-pt3)}. 10 | #' @export 11 | line2plane <- function(ptLine,ptDir, planePt, planeNorm) { 12 | d <- crossprod(planeNorm,planePt) 13 | t <- (d-crossprod(planeNorm,ptLine))/crossprod(planeNorm,ptDir) 14 | out <- ptLine+t*ptDir 15 | if (!length(out)) 16 | stop("plane and line are collinear") 17 | return(out) 18 | } 19 | -------------------------------------------------------------------------------- /man/barycenter.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/barycenter.r 3 | \name{barycenter} 4 | \alias{barycenter} 5 | \title{calculates the barycenters for all faces of a triangular mesh} 6 | \usage{ 7 | barycenter(mesh) 8 | } 9 | \arguments{ 10 | \item{mesh}{triangular mesh of class 'mesh3d'} 11 | } 12 | \value{ 13 | k x 3 matrix of barycenters for all \code{k} faces of input mesh. 14 | } 15 | \description{ 16 | calculates the barycenters for all faces of a triangular mesh 17 | } 18 | \examples{ 19 | 20 | 21 | data(nose) 22 | bary <- barycenter(shortnose.mesh) 23 | \dontrun{ 24 | require(rgl) 25 | ##visualize mesh 26 | wire3d(shortnose.mesh) 27 | # visualize barycenters 28 | points3d(bary, col=2) 29 | ## now each triangle is equipped with a point in its barycenter 30 | } 31 | } 32 | \seealso{ 33 | \code{\link{closemeshKD}} 34 | } 35 | -------------------------------------------------------------------------------- /man/quad2trimesh.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/quad2trimesh.r 3 | \name{quad2trimesh} 4 | \alias{quad2trimesh} 5 | \title{converts a mesh containing quadrangular faces into one only consisting of triangles} 6 | \usage{ 7 | quad2trimesh(mesh, updateNormals = TRUE) 8 | } 9 | \arguments{ 10 | \item{mesh}{object of class "mesh3d"} 11 | 12 | \item{updateNormals}{logical: request recalculation of (angle weighted) vertex normals.} 13 | } 14 | \value{ 15 | triangular mesh with updated normals 16 | } 17 | \description{ 18 | converts a mesh containing quadrangular faces into one only consisting of triangles 19 | } 20 | \examples{ 21 | 22 | Sigma <- diag(3:1) #create a 3D-covariance matrix 23 | require(rgl) 24 | quadmesh <- ellipse3d(Sigma)##create quadmesh 25 | trimesh <- quad2trimesh(quadmesh)# convert to trimesh 26 | 27 | 28 | } 29 | -------------------------------------------------------------------------------- /man/mergeMeshes.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/mergeMeshes.r 3 | \name{mergeMeshes} 4 | \alias{mergeMeshes} 5 | \title{merge multiple triangular meshes into a single one} 6 | \usage{ 7 | mergeMeshes(...) 8 | } 9 | \arguments{ 10 | \item{\dots}{triangular meshes of class \code{'mesh3d'} to merge or a list 11 | of triangular meshes.} 12 | } 13 | \value{ 14 | returns the meshes merged into a single one. 15 | } 16 | \description{ 17 | merge multiple triangular meshes into a single one, preserving color and 18 | vertex normals. 19 | } 20 | \examples{ 21 | 22 | require(rgl) 23 | data(boneData) 24 | data(nose) 25 | mergedMesh <- mergeMeshes(shortnose.mesh, skull_0144_ch_fe.mesh) 26 | \dontrun{ 27 | require(rgl) 28 | shade3d(mergedMesh, col=3) 29 | } 30 | 31 | } 32 | \seealso{ 33 | \code{\link{mesh2ply}, \link{file2mesh}, \link{ply2mesh}} 34 | } 35 | -------------------------------------------------------------------------------- /tests/testthat/test-mirror.r: -------------------------------------------------------------------------------- 1 | context("mirror functions") 2 | 3 | test_that("mirror.matrix behaves", { 4 | boneMir.baseline=structure(c(125.048055055629, 125.337650940873, 121.294041363046, 5 | 128.549755916167, 117.262978257761, 128.708329677512, 114.015199391521, 6 | 133.141679085682, 122.716932933575, 123.488377378233, 44.6403187557201, 7 | 44.9064753775645, 48.309875510538, 48.5435509841916, 55.9361737827255, 8 | 56.3929693160991, 56.8352669034508, 57.657380761555, 54.4230460742932, 9 | 40.7425425338623, 76.4985127131541, 80.057848539667, 78.1445857853691, 10 | 77.6344304495789, 28.8906474576085, 28.8284524490006, 31.1040380007055, 11 | 31.423573621832, 22.511397330662, 44.668913652422), .Dim = c(10L, 12 | 3L)) 13 | data(boneData) 14 | expect_equal(mirror(boneLM[,,1],icpiter=50,pcAlign=T,mirroraxis=3), boneMir.baseline, tol=1e-6) 15 | 16 | }) 17 | -------------------------------------------------------------------------------- /man/predictPLSfromScores.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/pls2B.r 3 | \name{predictPLSfromScores} 4 | \alias{predictPLSfromScores} 5 | \title{predict data from 2-Block PLS-scores} 6 | \usage{ 7 | predictPLSfromScores(pls, x, y) 8 | } 9 | \arguments{ 10 | \item{pls}{output of pls2B} 11 | 12 | \item{x}{scores associated with dataset x in original pls2B} 13 | 14 | \item{y}{scores associated with dataset y in original pls2B} 15 | } 16 | \value{ 17 | returns an array/matrix of landmarks or original values, depending on input for computing \code{pls} 18 | } 19 | \description{ 20 | predict data from 2-Block PLS-scores 21 | } 22 | \note{ 23 | either x or y must be missing. If x-scores are provided, the yscores will be estimated and the predictions calculated. 24 | } 25 | \seealso{ 26 | \code{\link{pls2B}, \link{getPLSscores},\link{predictPLSfromData}} 27 | } 28 | -------------------------------------------------------------------------------- /R/addo.r: -------------------------------------------------------------------------------- 1 | addo <- function(arr) { 2 | if (!is.numeric(arr) || length(dim(arr)) != 3) 3 | stop("please provide 3D numeric array") 4 | out <- .Call("addoCpp",arr) 5 | return(out) 6 | } 7 | #' calculate mean of an array 8 | #' 9 | #' calculate mean of a 3D-array (e.g. containing landmarks) (fast) using the Armadillo C++ Backend 10 | #' 11 | #' @param arr \code{k x m x n} dimensional numeric array 12 | #' @return matrix of dimensions \code{k x m}. 13 | #' @note this is the same as \code{apply(arr, 1:2, mean)}, only faster for large configurations. 14 | #' @examples 15 | #' data(boneData) 16 | #' proc <- ProcGPA(boneLM, silent = TRUE) 17 | #' mshape <- arrMean3(proc$rotated) 18 | #' @export 19 | arrMean3 <- function(arr) { 20 | if (!is.numeric(arr) || length(dim(arr)) != 3) 21 | stop("please provide 3D numeric array") 22 | out <- .Call("arrMean3Cpp",arr) 23 | return(out) 24 | } 25 | -------------------------------------------------------------------------------- /R/read.pts.r: -------------------------------------------------------------------------------- 1 | #' reads pts files 2 | #' 3 | #' reads Landmark data exported from the software Landmark from 4 | #' http://graphics.idav.ucdavis.edu/research/EvoMorph 5 | #' 6 | #' 7 | #' @param file pts file 8 | #' @param na specifies a value that indicates missing values 9 | #' @return 10 | #' \item{matrix }{matrix containing landmark information rownames will be 11 | #' the names given to the landmarks in Landmark} 12 | #' @seealso \code{\link{read.pts}} 13 | #' 14 | #' @examples 15 | #' 16 | #' data(nose) 17 | #' write.pts(shortnose.lm, filename="shortnose") 18 | #' data <- read.pts("shortnose.pts") 19 | #' 20 | #' @export 21 | read.pts <- function(file="x", na=9999) 22 | { 23 | pts <- read.table(file,skip=2) 24 | rownames(pts) <- pts[,1] 25 | pts <- as.matrix(pts[,2:4]) 26 | nas <- which(pts == na) 27 | if (length(nas) > 0) 28 | pts[nas] <- NA 29 | return(pts) 30 | } 31 | -------------------------------------------------------------------------------- /man/readallTPS.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/readallTPS.r 3 | \name{readallTPS} 4 | \alias{readallTPS} 5 | \title{Import landmarks and outlines from TPS files} 6 | \usage{ 7 | readallTPS(file) 8 | } 9 | \arguments{ 10 | \item{file}{A TPS-file generated by tpsdig2} 11 | } 12 | \value{ 13 | \item{ID }{Specimen IDs read from TPS file} 14 | \item{LM }{list of landmarks contained in the TPS-file} 15 | \item{outlines }{a list containing sublists for each specimen with all 16 | the outlines read from TPS file} 17 | } 18 | \description{ 19 | Imports outlines and landmarks from files generated by tpsdig2 20 | } 21 | \note{ 22 | currently only landmarks, ID and outlines are read from the TPS-file 23 | } 24 | \references{ 25 | http://life.bio.sunysb.edu/ee/rohlf/software.html 26 | } 27 | \seealso{ 28 | \code{\link{read.lmdta}}, \code{\link{read.pts}} 29 | } 30 | \author{ 31 | Stefan Schlager 32 | } 33 | -------------------------------------------------------------------------------- /.travis.yml: -------------------------------------------------------------------------------- 1 | # Sample .travis.yml for R projects. 2 | # 3 | # See README.md for instructions, or for more configuration options, 4 | # see the wiki: 5 | # https://github.com/craigcitro/r-travis/wiki 6 | 7 | language: c 8 | sudo: required 9 | dist: trusty 10 | 11 | before_install: 12 | - sudo add-apt-repository ppa:zarquon42/travis-trusty -y 13 | - sudo apt-get update -qq 14 | - curl -OL http://raw.github.com/craigcitro/r-travis/master/scripts/travis-tool.sh 15 | - export RGL_USE_NULL=TRUE 16 | - chmod 755 ./travis-tool.sh 17 | - ./travis-tool.sh bootstrap 18 | - ./travis-tool.sh install_r_binary rgl Rcpp RcppEigen RcppArmadillo foreach doParallel yaImpute testthat car colorRamps shapes rvcg 19 | install: 20 | - ./travis-tool.sh install_deps 21 | script: ./travis-tool.sh run_tests 22 | 23 | after_failure: 24 | - ./travis-tool.sh dump_logs 25 | 26 | notifications: 27 | email: 28 | on_success: change 29 | on_failure: change 30 | -------------------------------------------------------------------------------- /man/createMissingList.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/createMissingList.r 3 | \name{createMissingList} 4 | \alias{createMissingList} 5 | \title{create a list with empty entries to be used as missingList in slider3d} 6 | \usage{ 7 | createMissingList(x) 8 | } 9 | \arguments{ 10 | \item{x}{length of the list to be created} 11 | } 12 | \value{ 13 | returns a list of length \code{x} filled with numerics of length zero. 14 | } 15 | \description{ 16 | create a list with empty entries to be used as missingList in slider3d 17 | } 18 | \examples{ 19 | ## Assume in a sample of 10, the 9th individual has (semi-)landmarks 10:50 20 | # hanging in thin air (e.g. estimated using fixLMtps) 21 | # while the others are complete. 22 | ## create empty list 23 | missingList <- createMissingList(10) 24 | missingList[[9]] <- 10:50 25 | } 26 | \seealso{ 27 | \code{\link{fixLMtps},\link{fixLMmirror}, \link{slider3d}} 28 | } 29 | -------------------------------------------------------------------------------- /src/createL.cpp: -------------------------------------------------------------------------------- 1 | #include 2 | 3 | using namespace Rcpp; 4 | using namespace std; 5 | using namespace arma; 6 | 7 | RcppExport SEXP createL(SEXP Matrix_, SEXP threads_= wrap(1)) { 8 | try { 9 | mat MatrixA = as(Matrix_); 10 | int threads = as(threads_); 11 | int k = MatrixA.n_rows; 12 | mat K(k,k); K.zeros(); 13 | int m = MatrixA.n_cols; 14 | #pragma omp parallel for schedule(static) num_threads(threads) 15 | for (int i=0; i < (k-1); ++i) { 16 | for(int j=(i+1); j < k; ++j) { 17 | mat diff = MatrixA.row(i)-MatrixA.row(j); 18 | if (m == 3) 19 | K(i,j) = -sqrt(dot(diff,diff)); 20 | if (m == 2) { 21 | double r2 = dot(diff,diff); 22 | K(i,j) = r2*log(r2); 23 | } 24 | } 25 | } 26 | K = K+K.t(); 27 | return wrap(K); 28 | } catch (std::exception& e) { 29 | ::Rf_error( e.what()); 30 | } catch (...) { 31 | ::Rf_error("unknown exception"); 32 | } 33 | } 34 | 35 | -------------------------------------------------------------------------------- /R/meshDistZExport.r: -------------------------------------------------------------------------------- 1 | #' @rdname render 2 | #' @export 3 | export <- function(x,...)UseMethod("export") 4 | 5 | #' @rdname render 6 | #' @method export meshDist 7 | #' @export 8 | export.meshDist <- function(x,file="default",imagedim="100x800",...) 9 | { 10 | tol <- x$params$tol 11 | colramp <- x$colramp 12 | widxheight <- as.integer(strsplit(imagedim,split="x")[[1]]) 13 | mesh2ply(x$colMesh,col=x$cols,filename=file) 14 | png(filename=paste(file,".png",sep=""),width=widxheight[1],height=widxheight[2]) 15 | diffo <- ((colramp[[2]][2]-colramp[[2]][1])/2) 16 | image(colramp[[1]],colramp[[2]][-1]-diffo,t(colramp[[3]][1,-1])-diffo,col=colramp[[4]],useRaster=TRUE,ylab="Distance in mm",xlab="",xaxt="n") 17 | if (!is.null(tol)) { 18 | if (sum(abs(tol)) != 0) { 19 | image(colramp[[1]],c(tol[1],tol[2]),matrix(c(tol[1],tol[2]),1,1),col="green",useRaster=TRUE,add=TRUE) 20 | } 21 | } 22 | dev.off() 23 | } 24 | -------------------------------------------------------------------------------- /R/meshres.r: -------------------------------------------------------------------------------- 1 | #' calculate average edge length of a triangular mesh 2 | #' 3 | #' calculate average edge length of a triangular mesh, by iterating over all 4 | #' faces. 5 | #' 6 | #' 7 | #' @param mesh triangular mesh stored as object of class "mesh3d" 8 | #' @return returns average edge length (a.k.a. mesh resolution) 9 | #' @author Stefan Schlager 10 | #' 11 | #' @examples 12 | #' 13 | #' data(boneData) 14 | #' mres <- meshres(skull_0144_ch_fe.mesh) 15 | #' 16 | #' 17 | #' @export 18 | meshres <- function(mesh) 19 | { 20 | if (!inherits(mesh,"mesh3d")) 21 | stop("please provide object of class mesh3d") 22 | if (!is.null(mesh$it)) 23 | it <- mesh$it-1 24 | else 25 | stop("mesh has no triangular faces") 26 | vb <- mesh$vb[1:3,] 27 | if (!is.matrix(vb) || !is.numeric(vb)) 28 | stop("vertices must be a numeric matrix") 29 | res <- .Call("meshresCpp",vb,it) 30 | return(res) 31 | } 32 | 33 | -------------------------------------------------------------------------------- /man/getPCscores.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/showPC.r 3 | \name{getPCscores} 4 | \alias{getPCscores} 5 | \title{Obtain PC-scores for new landmark data} 6 | \usage{ 7 | getPCscores(x, PC, mshape) 8 | } 9 | \arguments{ 10 | \item{x}{landmarks aligned (e.g. using \code{\link{align2procSym}} to the meanshape of data the PCs are derived from.} 11 | 12 | \item{PC}{Principal components (eigenvectors of the covariance matrix)} 13 | 14 | \item{mshape}{matrix containing the meanshape's landmarks (used to center the data)} 15 | } 16 | \value{ 17 | returns a matrix containing the PC scores 18 | } 19 | \description{ 20 | Obtain PC-scores for new landmark data 21 | } 22 | \examples{ 23 | data(boneData) 24 | proc <- procSym(boneLM[,,-c(1:2)]) 25 | newdata <- boneLM[,,c(1:2)] 26 | newdataAlign <- align2procSym(proc,newdata) 27 | scores <- getPCscores(newdataAlign,proc$PCs,proc$mshape) 28 | } 29 | \seealso{ 30 | \code{\link{showPC}} 31 | } 32 | -------------------------------------------------------------------------------- /src/ang_calc.cpp: -------------------------------------------------------------------------------- 1 | #include "doozers.h" 2 | using namespace Rcpp; 3 | 4 | RcppExport SEXP ang_calcC(SEXP x_, SEXP y_) { 5 | try{ 6 | NumericMatrix x(x_); 7 | NumericVector angle(x.nrow()); 8 | NumericVector y(y_); 9 | for (int i = 0; i < x.nrow(); i++) { 10 | angle(i) = angcalcRcpp(x(i,_),y); 11 | } 12 | 13 | return wrap(angle); 14 | } catch (std::exception& e) { 15 | ::Rf_error( e.what()); 16 | } catch (...) { 17 | ::Rf_error("unknown exception"); 18 | } 19 | } 20 | 21 | 22 | RcppExport SEXP ang_calcM(SEXP x_, SEXP y_) { 23 | try{ 24 | NumericMatrix x(x_); 25 | NumericVector angle(x.nrow()); 26 | NumericMatrix y(y_); 27 | 28 | for (int i = 0; i < x.nrow(); i++) { 29 | angle(i) = angcalcRcpp(x(i,_),y(i,_)); 30 | } 31 | 32 | return wrap(angle); 33 | } catch (std::exception& e) { 34 | ::Rf_error( e.what()); 35 | } catch (...) { 36 | ::Rf_error("unknown exception"); 37 | } 38 | } 39 | 40 | -------------------------------------------------------------------------------- /src/meshres.cpp: -------------------------------------------------------------------------------- 1 | #include 2 | using namespace Rcpp; 3 | using namespace std; 4 | using namespace arma; 5 | 6 | RcppExport SEXP meshresCpp(SEXP vb_, SEXP it_) { 7 | try { 8 | 9 | arma::mat vbA = Rcpp::as(vb_); 10 | //mat vbA(vb.begin(),vb.nrow(),vb.ncol()); 11 | imat itA = as(it_); 12 | int nit = itA.n_cols; 13 | //imat itA(it.begin(),it.nrow(),it.ncol()); 14 | vec tmp(3); 15 | double res = 0.0; 16 | for (int i=0; i < nit;++i) { 17 | tmp = vbA.col(itA(0,i))-vbA.col(itA(1,i)); 18 | res += sqrt(dot(tmp,tmp)); 19 | tmp = vbA.col(itA(0,i))-vbA.col(itA(2,i)); 20 | res += sqrt(dot(tmp,tmp)); 21 | tmp = vbA.col(itA(1,i))-vbA.col(itA(2,i)); 22 | res += sqrt(dot(tmp,tmp)); 23 | } 24 | res /= nit*3; 25 | return wrap(res); 26 | } catch (std::exception& e) { 27 | ::Rf_error( e.what()); 28 | } catch (...) { 29 | ::Rf_error("unknown exception"); 30 | } 31 | } 32 | -------------------------------------------------------------------------------- /man/cExtract.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/cExtract.r 3 | \name{cExtract} 4 | \alias{cExtract} 5 | \title{extract information about fixed landmarks, curves and patches from and atlas 6 | generated by "landmark"} 7 | \usage{ 8 | cExtract(pts.file) 9 | } 10 | \arguments{ 11 | \item{pts.file}{either a character naming the path to a pts.file or the name 12 | of an object imported via read.pts.} 13 | } 14 | \value{ 15 | returns a list containing the vectors with the indices of matrix 16 | rows belonging to the in "landmark" defined curves, patches and fix 17 | landmarks and a matrix containing landmark coordinates. 18 | } 19 | \description{ 20 | After exporting the pts file of the atlas from "landmark" and importing it 21 | into R via "read.pts" cExtract gets information which rows of the landmark 22 | datasets belong to curves or patches. 23 | } 24 | \seealso{ 25 | \code{\link{read.lmdta}} ,\code{\link{read.pts}} 26 | } 27 | \author{ 28 | Stefan Schlager 29 | } 30 | -------------------------------------------------------------------------------- /man/classify.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/classify.r 3 | \name{classify} 4 | \alias{classify} 5 | \alias{classify.bgPCA} 6 | \alias{classify.CVA} 7 | \alias{classify.typprob} 8 | \title{classify specimen based on between-group PCA or CVA or typprobClass} 9 | \usage{ 10 | classify(x, cv = TRUE) 11 | 12 | \method{classify}{bgPCA}(x, cv = TRUE) 13 | 14 | \method{classify}{CVA}(x, cv = T) 15 | 16 | \method{classify}{typprob}(x, cv = TRUE) 17 | } 18 | \arguments{ 19 | \item{x}{result of groupPCA, CVA or typprobClass} 20 | 21 | \item{cv}{logical: use cross-validated scores if available} 22 | } 23 | \value{ 24 | \item{class}{classification result} 25 | \item{groups}{original grouping variable} 26 | 27 | for object of CVA and typprob, also the posterior probabilities are returned. 28 | } 29 | \description{ 30 | classify specimen based on between-group PCA, CVA or typprobClass 31 | } 32 | \seealso{ 33 | \code{\link{CVA},\link{groupPCA}, \link{typprobClass}} 34 | } 35 | -------------------------------------------------------------------------------- /man/plot.slider3d.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/slider3d.r 3 | \name{plot.slider3d} 4 | \alias{plot.slider3d} 5 | \title{plot the result of slider3d} 6 | \usage{ 7 | \method{plot}{slider3d}(x, cols = 2:4, pt.size = NULL, point = c("sphere", 8 | "point"), specimen = 1, add = TRUE, ...) 9 | } 10 | \arguments{ 11 | \item{x}{result of \code{slider3d} call} 12 | 13 | \item{cols}{vector containing colors for each coordinate type cols[1]=landmarks, cols[2]=surface landmarks, cols[3]=outlines.} 14 | 15 | \item{pt.size}{size of plotted points/spheres. If \code{point="s"}. 16 | \code{pt.size} defines the radius of the spheres. If \code{point="p"} it 17 | sets the variable \code{size} used in \code{point3d}.} 18 | 19 | \item{point}{how to render landmarks.} 20 | 21 | \item{specimen}{integer: select the specimen to plot} 22 | 23 | \item{add}{logical: if TRUE, a new rgl window is opened.} 24 | 25 | \item{...}{additonal, currently unused parameters} 26 | } 27 | \description{ 28 | plot the result of slider3d 29 | } 30 | -------------------------------------------------------------------------------- /R/obj2mesh.r: -------------------------------------------------------------------------------- 1 | #' @rdname ply2mesh 2 | #' @export 3 | obj2mesh <- function(filename,adnormals=TRUE) 4 | { 5 | obj <- read.obj(filename) 6 | vert <- obj[which(obj[,1]=="v"),1:4] 7 | 8 | face <- obj[which(obj[,1]=="f"),1:4] 9 | vn <- obj[which(obj[,1]=="vn"),1:4] 10 | face.mat <- as.matrix(face[,2:4]) 11 | vert.mat <- apply(vert[,2:4],2,as.numeric) 12 | 13 | if (length(grep("//",face.mat[1,1]))!=0) { 14 | write.table(face.mat,file="facedump", quote = F, row.names = FALSE, col.names = FALSE, na = "",sep="//") 15 | face.mat <- read.table("facedump",sep="/")[,c(1,5,9)] 16 | unlink("facedump") 17 | } 18 | mesh <- list() 19 | class(mesh) <- "mesh3d" 20 | mesh$vb <- rbind(t(vert.mat),1) 21 | mesh$it <- t(face.mat) 22 | if (dim(vn)[1] != 0) { 23 | normals <- apply(vn[,2:4], 2, as.numeric) 24 | mesh$normals <- rbind(t(normals),1) 25 | } 26 | 27 | if (adnormals && is.null(mesh$normals)) 28 | mesh <- vcgUpdateNormals(mesh) 29 | 30 | return(mesh) 31 | } 32 | -------------------------------------------------------------------------------- /man/predictPLSfromData.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/pls2B.r 3 | \name{predictPLSfromData} 4 | \alias{predictPLSfromData} 5 | \title{predict 2 Block-PLS from new data} 6 | \usage{ 7 | predictPLSfromData(pls, x, y, ncomp = NULL) 8 | } 9 | \arguments{ 10 | \item{pls}{output of pls2B} 11 | 12 | \item{x}{data in the same format as in original pls2B (for landmarks this can be an array or a matrix and for other data a matrix of a vector)} 13 | 14 | \item{y}{data in the same format as in original pls2B (for landmarks this can be an array or a matrix and for other data a matrix of a vector)} 15 | 16 | \item{ncomp}{number of (latent) components to use for prediction.} 17 | } 18 | \value{ 19 | returns an array/matrix/vector of predictions - depending on input for computing \code{pls} 20 | } 21 | \description{ 22 | predict 2 Block-PLS from new data 23 | } 24 | \note{ 25 | either x or y must be missing 26 | } 27 | \examples{ 28 | ##see examples in pls2B 29 | } 30 | \seealso{ 31 | \code{\link{pls2B}, \link{getPLSscores},\link{predictPLSfromScores}} 32 | } 33 | -------------------------------------------------------------------------------- /man/write.pts.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/write.pts.r 3 | \name{write.pts} 4 | \alias{write.pts} 5 | \title{exports a matrix containing landmarks into .pts format} 6 | \usage{ 7 | write.pts(x, filename = dataname, rownames = NULL) 8 | } 9 | \arguments{ 10 | \item{x}{k x m matrix containing landmark configuration} 11 | 12 | \item{filename}{character: Path/name of the requested output - extension 13 | will be added atuomatically. If not specified, the file will be named as the 14 | exported object.} 15 | 16 | \item{rownames}{provide an optional character vector with rownames} 17 | } 18 | \description{ 19 | exports a matrix containing landmarks into .pts format that can be read by 20 | IDAV Landmark. 21 | } 22 | \details{ 23 | you can import the information into the program landmarks available at 24 | http://graphics.idav.ucdavis.edu/research/EvoMorph 25 | } 26 | \examples{ 27 | 28 | data(nose) 29 | write.pts(shortnose.lm, filename="shortnose") 30 | 31 | } 32 | \seealso{ 33 | \code{\link{read.pts}} 34 | } 35 | \author{ 36 | Stefan Schlager 37 | } 38 | -------------------------------------------------------------------------------- /man/cutMeshPlane.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/cutSpace.r 3 | \name{cutMeshPlane} 4 | \alias{cutMeshPlane} 5 | \title{cut a mesh by a hyperplane and remove parts above/below that plane} 6 | \usage{ 7 | cutMeshPlane(mesh, v1, v2 = NULL, v3 = NULL, normal = NULL, 8 | keep.upper = TRUE) 9 | } 10 | \arguments{ 11 | \item{mesh}{triangular mesh of class "mesh3d"} 12 | 13 | \item{v1}{numeric vector of length=3 specifying a point on the separating plane} 14 | 15 | \item{v2}{numeric vector of length=3 specifying a point on the separating plane} 16 | 17 | \item{v3}{numeric vector of length=3 specifying a point on the separating plane} 18 | 19 | \item{normal}{plane normal (overrides specification by v2 and v3)} 20 | 21 | \item{keep.upper}{logical specify whether the points above or below the plane are should be kept} 22 | } 23 | \value{ 24 | mesh with part above/below hyperplane removed 25 | } 26 | \description{ 27 | cut a mesh by a hyperplane and remove parts above/below that plane 28 | } 29 | \details{ 30 | see \code{\link{cutSpace}} for more details. 31 | } 32 | -------------------------------------------------------------------------------- /man/scalemesh.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/scalemesh.r 3 | \name{scalemesh} 4 | \alias{scalemesh} 5 | \title{scale a mesh of class "mesh3d"} 6 | \usage{ 7 | scalemesh(mesh, size, center = c("bbox", "mean", "none")) 8 | } 9 | \arguments{ 10 | \item{mesh}{object of class "mesh3d"} 11 | 12 | \item{size}{numeric: scale factor} 13 | 14 | \item{center}{character: method to position center of mesh after scaling: 15 | values are "bbox", and "mean". See Details for more info.} 16 | } 17 | \value{ 18 | returns a scaled mesh 19 | } 20 | \description{ 21 | scales (the vertices of a mesh by a scalar 22 | } 23 | \details{ 24 | The mesh's center is determined either as mean of the bounding box 25 | (center="bbox") or mean of vertex coordinates (center="mean") and then 26 | scaled according to the scaling factor. If center="none", vertex coordinates 27 | will simply be multiplied by "size". 28 | } 29 | \examples{ 30 | 31 | data(nose) 32 | #inflate mesh by factor 4 33 | largenose <- scalemesh(shortnose.mesh,4) 34 | 35 | } 36 | \seealso{ 37 | \code{\link{rotmesh.onto}} 38 | } 39 | \author{ 40 | Stefan Schlager 41 | } 42 | -------------------------------------------------------------------------------- /man/bindArr.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/bindArr.r 3 | \name{bindArr} 4 | \alias{bindArr} 5 | \title{concatenate multiple arrays/matrices} 6 | \usage{ 7 | bindArr(..., along = 1) 8 | } 9 | \arguments{ 10 | \item{\dots}{matrices and/or arrays with appropriate dimensionality to 11 | combine to one array, or a single list containing suitable matrices, or arrays).} 12 | 13 | \item{along}{dimension along which to concatenate.} 14 | } 15 | \value{ 16 | returns array of combined matrices/arrays 17 | } 18 | \description{ 19 | concatenate multiple 3-dimensional arrays and/or 2-dimensional matrices to 20 | one big array 21 | } 22 | \details{ 23 | dimnames, if present and if differing between entries, will be concatenated, separated by a "_". 24 | } 25 | \examples{ 26 | 27 | A <- matrix(rnorm(18),6,3) 28 | B <- matrix(rnorm(18),6,3) 29 | C <- matrix(rnorm(18),6,3) 30 | 31 | #combine to 3D-array 32 | newArr <- bindArr(A,B,C,along=3) 33 | #combine along first dimension 34 | newArr2 <- bindArr(newArr,newArr,along=1) 35 | 36 | 37 | 38 | } 39 | \seealso{ 40 | \code{\link{cbind}}, \code{\link{rbind}}, \code{\link{array}} 41 | } 42 | -------------------------------------------------------------------------------- /man/retroDeform3d.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/retrodeform.r 3 | \name{retroDeform3d} 4 | \alias{retroDeform3d} 5 | \title{symmetrize a bilateral landmark configuration} 6 | \usage{ 7 | retroDeform3d(mat, pairedLM, hmult = 5, alpha = 0.01) 8 | } 9 | \arguments{ 10 | \item{mat}{matrix with bilateral landmarks} 11 | 12 | \item{pairedLM}{2-column integer matrix with the 1st columns containing row indices of left side landmarks and 2nd column the right hand landmarks} 13 | 14 | \item{hmult}{factor controlling the bandwidth for calculating local weights (which will be \code{hmult} * average distance between landmarks and their closest neighbour).} 15 | 16 | \item{alpha}{factor controlling spacing along x-axis} 17 | } 18 | \value{ 19 | \item{deformed}{matrix containing deformed landmarks} 20 | \item{orig}{matrix containing original landmarks} 21 | } 22 | \description{ 23 | symmetrize a bilateral landmark configuration by removing bending and stretching 24 | } 25 | \references{ 26 | Ghosh, D.; Amenta, N. & Kazhdan, M. Closed-form Blending of Local Symmetries. Computer Graphics Forum, Wiley-Blackwell, 2010, 29, 1681-1688 27 | } 28 | -------------------------------------------------------------------------------- /man/plsCoVar.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/pls2B.r 3 | \name{plsCoVar} 4 | \alias{plsCoVar} 5 | \title{Get the shape changes from pls2B associated with each latent variable} 6 | \usage{ 7 | plsCoVar(pls, i, sdx = 3, sdy = 3) 8 | } 9 | \arguments{ 10 | \item{pls}{output of pls2B} 11 | 12 | \item{i}{integer: which latent variable to show. E.g. i=3 will show the changes associated with the 3rd latent variable.} 13 | 14 | \item{sdx}{standard deviation on the xscores. sdx=3 will show the effecs of +3sd vs -3sd} 15 | 16 | \item{sdy}{standard deviation on the yscores. sdy=3 will show the effecs of +3sd vs -3sd} 17 | } 18 | \value{ 19 | \item{x}{matrix/array with reconstructed x} 20 | \item{y}{matrix/array with reconstructed y, with each prediction named accordingly: e.g. neg_x_sd_3 means the prediction of x at a score of \code{-3*sd(Xscores)}}. 21 | } 22 | \description{ 23 | Get the shape changes from pls2B associated with each latent variable 24 | } 25 | \seealso{ 26 | \code{\link{pls2B}, \link{getPLSfromScores}, \link{predictPLSfromScores}, \link{getPLSscores}, \link{predictPLSfromData},\link{svd}, \link{plsCoVarCommonShape}} 27 | } 28 | -------------------------------------------------------------------------------- /R/mesh2grey.r: -------------------------------------------------------------------------------- 1 | RGB2Grey <- function(x,coefs = c(0.3, 0.59, 0.11)) 2 | { 3 | matr <- FALSE 4 | if (is.matrix(x)) 5 | {dimx <- dim(x) 6 | x <- as.vector(x) 7 | matr <- TRUE 8 | } 9 | rgbval <- col2rgb(x) 10 | greyval <- round((t(coefs)%*%rgbval)) 11 | greyval <- rgb(greyval,greyval,greyval,maxColorValue=255) 12 | 13 | if (matr) 14 | { 15 | greyval <- matrix(greyval,dimx[1],dimx[2]) 16 | } 17 | return(greyval) 18 | } 19 | 20 | 21 | 22 | #' convert a colored mesh to greyscale. 23 | #' 24 | #' convert the colors of a colored mesh to greyscale values 25 | #' 26 | #' 27 | #' @param mesh Object of class mesh3d 28 | #' @return returns a mesh with material$color replaced by greyscale rgb values. 29 | #' @author Stefan Schlager 30 | #' @seealso \code{\link{ply2mesh}},\code{\link{file2mesh}} 31 | #' 32 | #' @export 33 | mesh2grey <- function(mesh) 34 | { 35 | if (is.null(mesh$material$color)) 36 | { 37 | stop("mesh contains no colors") 38 | } 39 | else 40 | { 41 | mesh$material$color <- RGB2Grey(mesh$material$color) 42 | } 43 | return(mesh) 44 | } 45 | 46 | -------------------------------------------------------------------------------- /man/covW.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/typprob.r 3 | \name{covW} 4 | \alias{covW} 5 | \title{calculate the pooled within groups covariance matrix} 6 | \usage{ 7 | covW(data, groups, robust = c("classical", "mve", "mcd"), ...) 8 | } 9 | \arguments{ 10 | \item{data}{a matrix containing data} 11 | 12 | \item{groups}{grouping variables} 13 | 14 | \item{robust}{character: determines covariance estimation methods in case \code{sep=TRUE}, when covariance matrices and group means can be estimated robustly using \code{MASS::cov.rob}. Default is the standard product-moment covariance matrix.} 15 | 16 | \item{...}{additional parameters passed to \code{MASS::cov.rob} for robust covariance and mean estimations.} 17 | } 18 | \value{ 19 | Returns the pooled within group covariance matrix. The attributes contain the entry means, containing the respective group means. 20 | } 21 | \description{ 22 | calculate the pooled within groups covariance matrix 23 | } 24 | \examples{ 25 | data(iris) 26 | poolCov <- covW(iris[,1:4],iris[,5]) 27 | } 28 | \seealso{ 29 | \code{\link{cov}}, \code{\link{typprobClass}} 30 | } 31 | \author{ 32 | Stefan Schlager 33 | } 34 | -------------------------------------------------------------------------------- /man/qqmat.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/qqmat.r 3 | \name{qqmat} 4 | \alias{qqmat} 5 | \title{Q-Q plot to assess normality of data} 6 | \usage{ 7 | qqmat(x, output = FALSE, square = FALSE) 8 | } 9 | \arguments{ 10 | \item{x}{sample data: matrix or vector} 11 | 12 | \item{output}{logical: if TRUE results are returned} 13 | 14 | \item{square}{plot in a square window - outliers might be cut off.} 15 | } 16 | \value{ 17 | if \code{output=TRUE}, the following values are returned 18 | \item{x }{distances from an expected Gaussian distribution} 19 | \item{y }{observed distances - sorted} 20 | \item{d }{observed distances - unsorted} 21 | } 22 | \description{ 23 | qqmat plots Mahalanobisdistances of a given sample against those expected 24 | from a Gaussian distribution 25 | } 26 | \examples{ 27 | 28 | require(MASS) 29 | ### create normally distributed data 30 | data <- mvrnorm(100,mu=rep(0,5),Sigma = diag(5:1)) 31 | qqmat(data) 32 | 33 | ###create non normally distributed data 34 | data1 <- rchisq(100,df=3) 35 | qqmat(data1,square=FALSE) 36 | 37 | } 38 | \seealso{ 39 | \code{\link{qqplot}} 40 | } 41 | \author{ 42 | Stefan Schlager 43 | } 44 | -------------------------------------------------------------------------------- /R/quad2trimesh.r: -------------------------------------------------------------------------------- 1 | #' converts a mesh containing quadrangular faces into one only consisting of triangles 2 | #' 3 | #' converts a mesh containing quadrangular faces into one only consisting of triangles 4 | #' @param mesh object of class "mesh3d" 5 | #' @param updateNormals logical: request recalculation of (angle weighted) vertex normals. 6 | #' @return triangular mesh with updated normals 7 | #' @examples 8 | #' 9 | #' Sigma <- diag(3:1) #create a 3D-covariance matrix 10 | #' require(rgl) 11 | #' quadmesh <- ellipse3d(Sigma)##create quadmesh 12 | #' trimesh <- quad2trimesh(quadmesh)# convert to trimesh 13 | #' 14 | #' 15 | #' @export 16 | 17 | quad2trimesh <- function(mesh, updateNormals=TRUE) { 18 | if (!inherits(mesh,"mesh3d")) 19 | stop("please provide mesh of class mesh3d") 20 | if (is.null(mesh$ib)) { 21 | warning("this is no quadmesh, nothing to be done") 22 | } else { 23 | ib2it <- cbind(mesh$ib[1:3,,drop=FALSE],mesh$ib[c(3:4,1),,drop=FALSE]) 24 | mesh$it <- cbind(mesh$it,ib2it) 25 | mesh$ib <- NULL 26 | if (updateNormals) { 27 | mesh <- vcgUpdateNormals(mesh) 28 | } 29 | } 30 | return(mesh) 31 | } 32 | -------------------------------------------------------------------------------- /man/PCdist.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/PCdist.r 3 | \name{PCdist} 4 | \alias{PCdist} 5 | \title{correlation between a reduced space and the original space} 6 | \usage{ 7 | PCdist(PCs, PCscores, x = 5, plot.type = "b") 8 | } 9 | \arguments{ 10 | \item{PCs}{m x k matrix of Principal Components where m is the k is the 11 | number of PCs.} 12 | 13 | \item{PCscores}{n x m matrix of Principal Component scores where n is the 14 | number of observations.} 15 | 16 | \item{x}{integer: increment for every x-th PC the subspace to fullspace 17 | correlation will be calculated.} 18 | 19 | \item{plot.type}{"b"=barplot of correlation values, "s"=line between 20 | correlation values.} 21 | } 22 | \value{ 23 | a vector of R-squared values between subspace and fullspace 24 | distances and a barplot depicting the correlations belonging to the 25 | subspace. 26 | } 27 | \description{ 28 | Calculates the correlation between distances in a reduced space and the 29 | original space 30 | } 31 | \examples{ 32 | 33 | if (require(shapes)) { 34 | a <- procSym(gorf.dat) 35 | PCdist(a$PCs, a$PCscores, x = 2) 36 | } 37 | 38 | } 39 | \author{ 40 | Stefan Schlager 41 | } 42 | -------------------------------------------------------------------------------- /src/fastSubsetMeans.cpp: -------------------------------------------------------------------------------- 1 | #include "RcppArmadillo.h" 2 | using namespace Rcpp; 3 | using namespace arma; 4 | 5 | RcppExport SEXP fastSubsetMeans(SEXP x_, SEXP inds_, SEXP k_, SEXP threads_) { 6 | try { 7 | mat x = as(x_); 8 | int k = as(k_); 9 | uvec inds = as(inds_); 10 | int threads = as(threads_); 11 | mat center(k,x.n_cols); 12 | vec checkempty(k);checkempty.fill(0); 13 | 14 | center.fill(0); 15 | #pragma omp parallel for schedule(static) num_threads(threads) 16 | for (int i =0; i < k;i++) { 17 | uvec tmpinds = find(inds ==i); 18 | mat tmpmat = x.rows(tmpinds); 19 | rowvec tmpresult(x.n_cols);tmpresult.fill(0); 20 | if (tmpinds.size() == 0) 21 | checkempty(i) = 1; 22 | for (int j = 0; j < tmpinds.size();j++) 23 | tmpresult += tmpmat.row(j); 24 | tmpresult /= tmpinds.size(); 25 | center.row(i) = tmpresult; 26 | } 27 | List out = List::create(Named("centers")=center, 28 | Named("checkempty")=checkempty); 29 | 30 | return out; 31 | } catch (std::exception& e) { 32 | ::Rf_error( e.what()); 33 | } catch (...) { 34 | ::Rf_error("unknown exception"); 35 | } 36 | } 37 | -------------------------------------------------------------------------------- /man/readLandmarks.csv.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/readLandmarks.csv.r 3 | \name{readLandmarks.csv} 4 | \alias{readLandmarks.csv} 5 | \title{import landmark data from csv files} 6 | \usage{ 7 | readLandmarks.csv(file, x, y = 2:4, rownames = NULL, header = TRUE, 8 | dec = ".", sep = ";") 9 | } 10 | \arguments{ 11 | \item{file}{character: path to file containing landmark data.} 12 | 13 | \item{x}{either a vector specifiing which rows are to be imported, or 14 | character vector containing variable names to be sought for.} 15 | 16 | \item{y}{a vector specifiing, which columns of the speradsheet ist to be 17 | imported.} 18 | 19 | \item{rownames}{integer: specifies columns, where variable names are stored.} 20 | 21 | \item{header}{logical : if spreadsheet contains header-row.} 22 | 23 | \item{dec}{character: defines decimal sepearator.} 24 | 25 | \item{sep}{character: defines column seperator.} 26 | } 27 | \value{ 28 | \item{LM }{matrix containing imported data} 29 | \item{NAs }{vector containing rows containing NAs} 30 | } 31 | \description{ 32 | import landmark data from csv files 33 | } 34 | \seealso{ 35 | \code{\link{read.table}} 36 | } 37 | \author{ 38 | Stefan Schlager 39 | } 40 | -------------------------------------------------------------------------------- /man/meshPlaneIntersect.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/meshPlaneIntersect.r 3 | \name{meshPlaneIntersect} 4 | \alias{meshPlaneIntersect} 5 | \title{get intersections between mesh and a plane} 6 | \usage{ 7 | meshPlaneIntersect(mesh, v1, v2 = NULL, v3 = NULL, normal = NULL) 8 | } 9 | \arguments{ 10 | \item{mesh}{triangular mesh of class "mesh3d"} 11 | 12 | \item{v1}{numeric vector of length=3 specifying a point on the separating plane} 13 | 14 | \item{v2}{numeric vector of length=3 specifying a point on the separating plane} 15 | 16 | \item{v3}{numeric vector of length=3 specifying a point on the separating plane} 17 | 18 | \item{normal}{plane normal (overrides specification by v2 and v3)} 19 | } 20 | \value{ 21 | returns the intersections of edges and the plane 22 | } 23 | \description{ 24 | get intersections between mesh and a plane 25 | } 26 | \examples{ 27 | data(nose) 28 | v1 <- shortnose.lm[1,] 29 | v2 <- shortnose.lm[2,] 30 | v3 <- shortnose.lm[3,] 31 | intersect <- meshPlaneIntersect(shortnose.mesh,v1,v2,v3) 32 | \dontrun{ 33 | require(rgl) 34 | wire3d(shortnose.mesh) 35 | spheres3d(shortnose.lm[1:3,],col=2)#the plane 36 | spheres3d(intersect,col=3,radius = 0.2)#intersections 37 | } 38 | } 39 | -------------------------------------------------------------------------------- /src/edgePlane.cpp: -------------------------------------------------------------------------------- 1 | #include "doozers.h" 2 | using namespace Rcpp; 3 | 4 | RcppExport SEXP edgePlane(SEXP vb_, SEXP diff_, SEXP edges_) { 5 | try { 6 | IntegerMatrix edges(edges_); 7 | NumericMatrix vb(vb_); 8 | NumericMatrix diff(diff_); 9 | unsigned int nedges = edges.nrow(); 10 | mat out(nedges,3); out.zeros(); 11 | std::vector test; 12 | for (unsigned int i = 0; i < nedges; i++) { 13 | int i1 = edges(i,0); 14 | int i2 = edges(i,1); 15 | vec vb2 = vb(i2,_); 16 | vec diff0 = diff(i2,_); 17 | double ancath = sqrt(dot(diff0,diff0)); 18 | 19 | vec resvec = vb(i1,_)-vb(i2,_); 20 | double angle = angcalcArma(diff0,resvec); 21 | double lres = sqrt(dot(resvec,resvec)); 22 | resvec = resvec/lres; 23 | double hypoth = ancath/cos(angle); 24 | if (hypoth <= lres && hypoth >= 0) { 25 | out.row(i) = conv_to::from(vb2+hypoth*resvec); 26 | test.push_back(i); 27 | } 28 | } 29 | uvec myinds = conv_to::from(test); 30 | out = out.rows(myinds); 31 | return wrap(out); 32 | } catch (std::exception& e) { 33 | ::Rf_error( e.what()); 34 | } catch (...) { 35 | ::Rf_error("unknown exception"); 36 | } 37 | } 38 | 39 | -------------------------------------------------------------------------------- /man/vecx.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/vecx.r 3 | \name{vecx} 4 | \alias{vecx} 5 | \title{convert an 3D array into a matrix and back} 6 | \usage{ 7 | vecx(x, byrow = FALSE, revert = FALSE, lmdim) 8 | } 9 | \arguments{ 10 | \item{x}{array or matrix} 11 | 12 | \item{byrow}{logical: if TRUE, the resulting vector for each specimen will 13 | be \code{x1,y1,z1,x2,y2,z2,...,} and \code{x1,x2,...,y1,y2,...,z1,z2,...} otherwise 14 | (default). The same is for reverting the process: if the matrix contains the coordinates as rows like: \code{x1,y1,z1,x2,y2,z2,...} set \code{byrow=TRUE}} 15 | 16 | \item{revert}{revert the process and convert a matrix with vectorized landmarks back into an array.} 17 | 18 | \item{lmdim}{number of columns for reverting} 19 | } 20 | \value{ 21 | returns a matrix with one row per specimen 22 | } 23 | \description{ 24 | converts a 3D-array (e.g. containing landmark coordinates) into a matrix, 25 | one row per specimen or reverse this. 26 | } 27 | \examples{ 28 | 29 | if (require(shapes)) { 30 | data <- vecx(gorf.dat) 31 | #revert the procedure 32 | gdat.restored <- vecx(data,revert=TRUE,lmdim=2) 33 | range(gdat.restored-gorf.dat) 34 | } 35 | } 36 | \author{ 37 | Stefan Schlager 38 | } 39 | -------------------------------------------------------------------------------- /man/lineplot.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/lineplot.r 3 | \name{lineplot} 4 | \alias{lineplot} 5 | \title{plot lines between landmarks} 6 | \usage{ 7 | lineplot(x, point, col = 1, lwd = 1, line_antialias = FALSE, add = TRUE) 8 | } 9 | \arguments{ 10 | \item{x}{matrix containing 2D or 3D landmarks} 11 | 12 | \item{point}{vector or list of vectors containing rowindices of x, 13 | determining which landmarks to connect.} 14 | 15 | \item{col}{color of lines} 16 | 17 | \item{lwd}{line width} 18 | 19 | \item{line_antialias}{logical: smooth lines} 20 | 21 | \item{add}{logical: add to existing plot} 22 | } 23 | \description{ 24 | add lines connecting landmarks to visualise a sort of wireframe 25 | } 26 | \note{ 27 | works with 2D and 3D configurations 28 | } 29 | \examples{ 30 | 31 | 32 | if (require(shapes)) { 33 | ##2D example 34 | plot(gorf.dat[,,1],asp=1) 35 | lineplot(gorf.dat[,,1],point=c(1,5:2,8:6,1),col=2) 36 | } 37 | ##3D example 38 | \dontrun{ 39 | require(rgl) 40 | data(nose) 41 | points3d(shortnose.lm[1:9,]) 42 | lineplot(shortnose.lm[1:9,],point=list(c(1,3,2),c(3,4,5),c(8,6,5,7,9)),col=2) 43 | } 44 | 45 | } 46 | \seealso{ 47 | \code{\link{pcaplot3d}} 48 | } 49 | \author{ 50 | Stefan Schlager 51 | } 52 | -------------------------------------------------------------------------------- /R/barycenter.r: -------------------------------------------------------------------------------- 1 | #' calculates the barycenters for all faces of a triangular mesh 2 | #' 3 | #' calculates the barycenters for all faces of a triangular mesh 4 | #' 5 | #' 6 | #' @param mesh triangular mesh of class 'mesh3d' 7 | #' @return k x 3 matrix of barycenters for all \code{k} faces of input mesh. 8 | #' @seealso \code{\link{closemeshKD}} 9 | #' 10 | #' @examples 11 | #' 12 | #' 13 | #' data(nose) 14 | #' bary <- barycenter(shortnose.mesh) 15 | #' \dontrun{ 16 | #' require(rgl) 17 | #' ##visualize mesh 18 | #' wire3d(shortnose.mesh) 19 | #' # visualize barycenters 20 | #' points3d(bary, col=2) 21 | #' ## now each triangle is equipped with a point in its barycenter 22 | #' } 23 | #' @export 24 | barycenter <- function(mesh) 25 | { 26 | vb <- mesh$vb[1:3,] 27 | nvb <- dim(vb)[2] 28 | if (!is.matrix(vb) || !is.numeric(vb)) 29 | stop("vertices must be a numeric matrix") 30 | if (!is.null(mesh$it)) { 31 | rangeit <- range(mesh$it) 32 | if (rangeit[1] < 1 || rangeit[2] > ncol(vb)) 33 | stop("faces point beyond range of vertices") 34 | it <- mesh$it-1 35 | } else 36 | stop("mesh has no triangular faces") 37 | nit <- dim(it)[2] 38 | out <- .Call("barycenterCpp",vb,it) 39 | return(out) 40 | } 41 | -------------------------------------------------------------------------------- /R/groupPCAcrova.r: -------------------------------------------------------------------------------- 1 | .groupPCAcrova <- function(N, groups,tol=1e-10,groupPCs,weighting=weighting) 2 | { 3 | lev <- levels(groups) 4 | ng <- length(lev) 5 | gsizes <- as.vector(tapply(groups, groups, length)) 6 | 7 | if (length(dim(N)) == 3) 8 | N <- vecx(N) 9 | #n <- dim(N)[1] 10 | l <- dim(N)[2] 11 | Gmeans <- matrix(0, ng, l) 12 | for (i in 1:ng) { 13 | Gmeans[i, ] <- colMeans(N[groups==lev[i], ,drop=F]) 14 | } 15 | if (weighting) 16 | wt <- gsizes 17 | else 18 | wt <- rep(1,ng) 19 | wcov <- cov.wt(Gmeans,wt=wt) 20 | Grandm <- as.vector(wcov$center) 21 | eigenGmeans <- eigen(wcov$cov) 22 | N <- sweep(N, 2, Grandm) 23 | valScores <- which(eigenGmeans$values > tol) 24 | #groupScores <- N%*%(eigenGmeans$vectors[,valScores]) 25 | PCs <- as.matrix(eigenGmeans$vectors[,valScores]) 26 | 27 | if (is.null(dim(groupPCs))) { 28 | PCs <- matrix(PCs,length(PCs),1) 29 | groupPCs <- matrix(groupPCs,length(groupPCs),1) 30 | } 31 | di <- dim(PCs)[2] 32 | for (i in 1:di) { 33 | rho <- angle.calc(groupPCs[,i ],PCs[,i]) 34 | if (rho > pi/2) 35 | PCs[,i] <- PCs[,i]*(-1) 36 | } 37 | return(list(PCs=PCs,Grandmean=Grandm)) 38 | } 39 | -------------------------------------------------------------------------------- /man/mirror2plane.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/points2plane.r 3 | \name{mirror2plane} 4 | \alias{mirror2plane} 5 | \alias{mirror2plane.matrix} 6 | \alias{mirror2plane.mesh3d} 7 | \title{mirror points or mesh on an arbitrary plane} 8 | \usage{ 9 | mirror2plane(x, v1, normal = NULL, v2 = NULL, v3 = NULL) 10 | 11 | \method{mirror2plane}{matrix}(x, v1, normal = NULL, v2 = NULL, v3 = NULL) 12 | 13 | \method{mirror2plane}{mesh3d}(x, v1, normal = NULL, v2 = NULL, v3 = NULL) 14 | } 15 | \arguments{ 16 | \item{x}{x 3D-vector or a k x 3 matrix with 3D vectors stored in rows. Or a triangular mesh of class mesh3d} 17 | 18 | \item{v1}{point on plane} 19 | 20 | \item{normal}{plane normal (overrides specification by v2 and v3)} 21 | 22 | \item{v2}{if pNorm=NULL, the plane will be defined by three points \code{v1, v2, v3}} 23 | 24 | \item{v3}{if pNorm=NULL, the plane will be defined by three points \code{v1, v2, v3}} 25 | } 26 | \value{ 27 | mirrored coordinates mesh 28 | } 29 | \description{ 30 | mirror points or mesh on an arbitrary plane 31 | } 32 | \examples{ 33 | # mirror mesh on plane spanned by 3 midsagital landmarks 34 | data(boneData) 35 | mirrmesh <- mirror2plane(skull_0144_ch_fe.mesh,v1=boneLM[1,,1],v2=boneLM[9,,1],v3=boneLM[10,,1]) 36 | } 37 | -------------------------------------------------------------------------------- /DESCRIPTION: -------------------------------------------------------------------------------- 1 | Package: Morpho 2 | Type: Package 3 | Title: Calculations and Visualisations Related to Geometric Morphometrics 4 | Version: 2.5.1 5 | Date: 2017-04-19 6 | Authors@R: c( 7 | person("Stefan", "Schlager",, "zarquon42@gmail.com", c("aut", "cre", "cph")), 8 | person("Gregory", "Jefferis",,, c("ctb")) 9 | ) 10 | Description: A toolset for Geometric Morphometrics and mesh processing. This 11 | includes (among other stuff) mesh deformations based on reference points, 12 | permutation tests, detection of outliers, processing of sliding 13 | semi-landmarks and semi-automated surface landmark placement. 14 | Suggests: 15 | car, 16 | lattice, 17 | shapes, 18 | testthat 19 | Depends: 20 | R (>= 3.0.2) 21 | Imports: 22 | Rvcg (>= 0.7), 23 | rgl (>= 0.93.963), 24 | foreach (>= 1.4.0), 25 | Matrix (>= 1.0-1), 26 | MASS, 27 | parallel, 28 | doParallel (>= 1.0.6), 29 | colorRamps, 30 | Rcpp, 31 | graphics, 32 | grDevices, 33 | methods, 34 | stats, 35 | utils 36 | LinkingTo: Rcpp, RcppArmadillo (>= 0.4) 37 | Copyright: see COPYRIGHTS file for details 38 | License: GPL-2 39 | BugReports: https://github.com/zarquon42b/Morpho/issues 40 | LazyLoad: yes 41 | URL: https://github.com/zarquon42b/Morpho 42 | Encoding: UTF-8 43 | RoxygenNote: 6.0.1 44 | -------------------------------------------------------------------------------- /man/angleTest.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/angleTest.r 3 | \name{angleTest} 4 | \alias{angleTest} 5 | \title{Test whether the direction of two vectors is similar} 6 | \usage{ 7 | angleTest(x, y) 8 | } 9 | \arguments{ 10 | \item{x}{vector} 11 | 12 | \item{y}{vector} 13 | } 14 | \value{ 15 | a list with 16 | \item{angle}{angle between vectors} 17 | \item{p.value}{p-value for the probability that the angle between two random vectors is smaller or equal to the one calculatted from x and y} 18 | } 19 | \description{ 20 | Test whether the direction of two vectors is similar 21 | } 22 | \details{ 23 | Under the assumption of all (normalized) n-vectors being represented by an n-dimensional hypersphere, the probability of the angle between two vectors is <= the measured values can be estimated as the area of a cap defined by that angle and divided by the hypersphere's complete surface area. 24 | } 25 | \examples{ 26 | x <- c(1,0); y <- c(1,1) # for a circle this should give us p = 0.25 as the angle between vectors 27 | ## is pi/4 and for any vector the segment +-pi/4 covers a quarter of the circle 28 | angleTest(x,y) 29 | } 30 | \references{ 31 | S. Li , 2011. Concise Formulas for the Area and Volume of a Hyperspherical Cap. Asian Journal of Mathematics & Statistics, 4: 66-70. 32 | } 33 | -------------------------------------------------------------------------------- /man/r2morphoj.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/r2morphoj.r, R/r2morphologika.r 3 | \name{r2morphoj} 4 | \alias{r2morphoj} 5 | \alias{r2morphologika} 6 | \title{Export data to MorphoJ and Morphologika} 7 | \usage{ 8 | r2morphoj(x, file, id.string = NULL) 9 | 10 | r2morphologika(x, file = file, labels = NULL, labelname = NULL, ...) 11 | } 12 | \arguments{ 13 | \item{x}{3-dimensionla array containing landmark data. E.g. the input/output 14 | from \code{\link{procSym}}.} 15 | 16 | \item{file}{character: name the output file} 17 | 18 | \item{id.string}{a string with ids or factors to append} 19 | 20 | \item{labels}{character vector specify labels to create for Morphologika} 21 | 22 | \item{labelname}{character: name the labels for Morphologika.} 23 | 24 | \item{\dots}{unused at the moment} 25 | } 26 | \description{ 27 | Export data to MorphoJ and Morphologika 28 | } 29 | \details{ 30 | Export data to MorphoJ and Morphologika 31 | } 32 | \examples{ 33 | 34 | if (require(shapes)) { 35 | r2morphoj(gorf.dat,file="gorf.dat") 36 | 37 | data <- bindArr(gorf.dat, gorm.dat, along=3) 38 | datalabels <- c(rep("female",dim(gorf.dat)[3]), 39 | rep("male",dim(gorm.dat)[3])) 40 | labelname <- "sex" 41 | r2morphologika(data, labels=datalabels, labelname= labelname, file="data.dat") 42 | } 43 | } 44 | -------------------------------------------------------------------------------- /man/solutionSpace.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/solutionSpace.r 3 | \name{solutionSpace} 4 | \alias{solutionSpace} 5 | \title{returns the solution space (basis and translation vector) for an equation system} 6 | \usage{ 7 | solutionSpace(A, b) 8 | } 9 | \arguments{ 10 | \item{A}{numeric matrix} 11 | 12 | \item{b}{numeric vector} 13 | } 14 | \value{ 15 | \item{basis}{matrix containing the basis of the solution space} 16 | \item{translate}{translation vector} 17 | } 18 | \description{ 19 | returns the solution space (basis and translation vector) for an equation system 20 | } 21 | \details{ 22 | For a linear equationsystem, \eqn{Ax = b}{Ax = b}, the solution space then is 23 | \deqn{x = A^* b + (I - A^* A) y}{x = A'b + (I - A' A)} 24 | where \eqn{A^*}{A'} is the Moore-Penrose pseudoinverse of \eqn{A}{A}. 25 | The QR decomposition of \eqn{I - A^* A}{I - A'A} determines the dimension of and basis of the solution space. 26 | } 27 | \examples{ 28 | A <- matrix(rnorm(21),3,7) 29 | b <- c(1,2,3) 30 | subspace <- solutionSpace(A,b) 31 | dims <- ncol(subspace$basis) # we now have a 4D solution space 32 | ## now pick any vector from this space. E.g 33 | y <- 1:dims 34 | solution <- subspace$basis\%*\%y+subspace$translate # this is one solution for the equation above 35 | A\%*\%solution ## pretty close 36 | } 37 | -------------------------------------------------------------------------------- /man/showPC.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/showPC.r 3 | \name{showPC} 4 | \alias{showPC} 5 | \title{convert PCs to landmark configuration} 6 | \usage{ 7 | showPC(scores, PC, mshape) 8 | } 9 | \arguments{ 10 | \item{scores}{vector of PC-scores, or matrix with rows containing PC-scores} 11 | 12 | \item{PC}{Principal components (eigenvectors of the covariance matrix) 13 | associated with 'scores'.} 14 | 15 | \item{mshape}{matrix containing the meanshape's landmarks (used to center 16 | the data by the PCA)} 17 | } 18 | \value{ 19 | returns matrix or array containing landmarks 20 | } 21 | \description{ 22 | convert PC-scores to landmark coordinates 23 | } 24 | \details{ 25 | Rotates and translates PC-scores derived from shape data back into 26 | configuration space. 27 | } 28 | \examples{ 29 | 30 | if (require(shapes)) { 31 | ## generate landmarks using 32 | ##the first PC-score of the first specimen 33 | 34 | proc <- procSym(gorf.dat) 35 | lm <- showPC(proc$PCscores[1,1],proc$PCs[,1],proc$mshape) 36 | plot(lm,asp=1) 37 | 38 | ##now the first 3 scores 39 | lm2 <- showPC(proc$PCscores[1,1:3],proc$PCs[,1:3],proc$mshape) 40 | points(lm2,col=2) 41 | } 42 | } 43 | \seealso{ 44 | \code{\link{prcomp}}, \code{\link{procSym}} 45 | 46 | \code{\link{getPCscores}} 47 | } 48 | \author{ 49 | Stefan Schlager 50 | } 51 | -------------------------------------------------------------------------------- /man/tangentPlane.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/crossp.r, R/tanplan.r 3 | \name{crossProduct} 4 | \alias{crossProduct} 5 | \alias{tangentPlane} 6 | \title{calculate the orthogonal complement of a 3D-vector} 7 | \usage{ 8 | crossProduct(x, y) 9 | 10 | tangentPlane(x) 11 | } 12 | \arguments{ 13 | \item{x}{vector of length 3.} 14 | 15 | \item{y}{vector of length 3.} 16 | } 17 | \value{ 18 | tangentPlane: 19 | 20 | crossProduct: returns a vector of length 3. 21 | \item{y }{vector orthogonal to x} 22 | \item{z }{vector orthogonal to x and y} 23 | } 24 | \description{ 25 | calculate the orthogonal complement of a 3D-vector 26 | } 27 | \details{ 28 | calculate the orthogonal complement of a 3D-vector or the 3D-crossproduct, 29 | finding an orthogonal vector to a plane in 3D. 30 | } 31 | \examples{ 32 | 33 | require(rgl) 34 | 35 | x <- c(1,0,0) 36 | y <- c(0,1,0) 37 | 38 | #example tangentPlane 39 | z <- tangentPlane(x) 40 | #visualize result 41 | \dontrun{ 42 | lines3d(rbind(0, x), col=2, lwd=2) 43 | ## show complement 44 | lines3d(rbind(z$y, 0, z$z), col=3, lwd=2) 45 | } 46 | # example crossProduct 47 | z <- crossProduct(x, y) 48 | # show x and y 49 | \dontrun{ 50 | lines3d(rbind(x, 0, y), col=2, lwd=2) 51 | # show z 52 | lines3d(rbind(0, z), col=3, lwd=2) 53 | } 54 | } 55 | \author{ 56 | Stefan Schlager 57 | } 58 | -------------------------------------------------------------------------------- /man/applyTransform.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/applyTransform.r 3 | \name{applyTransform} 4 | \alias{applyTransform} 5 | \alias{applyTransform.matrix} 6 | \alias{applyTransform.mesh3d} 7 | \alias{applyTransform.default} 8 | \title{apply affine transformation to data} 9 | \usage{ 10 | applyTransform(x, trafo, inverse, threads) 11 | 12 | \method{applyTransform}{matrix}(x, trafo, inverse = FALSE, threads = 1) 13 | 14 | \method{applyTransform}{mesh3d}(x, trafo, inverse = FALSE, threads = 1) 15 | 16 | \method{applyTransform}{default}(x, trafo, inverse = FALSE, threads = 1) 17 | } 18 | \arguments{ 19 | \item{x}{matrix or mesh3d} 20 | 21 | \item{trafo}{4x4 transformation matrix or an object of class "tpsCoeff"} 22 | 23 | \item{inverse}{logical: if TRUE, the inverse of the transformation is applied (for TPS coefficients have to be recomputed)} 24 | 25 | \item{threads}{threads to be used for parallel execution in tps deformation.} 26 | } 27 | \value{ 28 | the transformed object 29 | } 30 | \description{ 31 | apply affine transformation to data 32 | } 33 | \examples{ 34 | data(boneData) 35 | rot <- rotonto(boneLM[,,1],boneLM[,,2]) 36 | trafo <- getTrafo4x4(rot) 37 | boneLM2trafo <- applyTransform(boneLM[,,2],trafo) 38 | } 39 | \seealso{ 40 | \code{\link{rotonto}, link{rotmesh.onto}, \link{tps3d}, \link{computeTransform}} 41 | } 42 | -------------------------------------------------------------------------------- /man/align2procSym.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/procSym.r 3 | \name{align2procSym} 4 | \alias{align2procSym} 5 | \title{align new data to an existing Procrustes registration} 6 | \usage{ 7 | align2procSym(x, newdata, orp = TRUE) 8 | } 9 | \arguments{ 10 | \item{x}{result of a \code{procSym} call} 11 | 12 | \item{newdata}{matrix or array of with landmarks corresponding to the data aligned in x} 13 | 14 | \item{orp}{logical: allows to skip orthogonal projection, even if it was used in the \code{procSym} call.} 15 | } 16 | \value{ 17 | an array with data aligned to the mean shape in x (and projected into tangent space) 18 | } 19 | \description{ 20 | align new data to an existing Procrustes registration 21 | } 22 | \note{ 23 | this will never yield the same result as a pooled Procrustes analysis because the sample mean is iteratively updated and new data would change the mean. 24 | } 25 | \examples{ 26 | require(Morpho) 27 | data(boneData) 28 | # run procSym on entire data set 29 | proc <- procSym(boneLM) 30 | # this is the training data 31 | array1 <- boneLM[,,1:60] 32 | newdata <- boneLM[,,61:80] 33 | proc1 <- procSym(array1) 34 | newalign <- align2procSym(proc1,newdata) 35 | ## compare alignment for one specimen to Proc. registration using all data 36 | \dontrun{ 37 | deformGrid3d(newalign[,,1],proc$orpdata[,,61]) 38 | } 39 | } 40 | -------------------------------------------------------------------------------- /src/permudistArma.cpp: -------------------------------------------------------------------------------- 1 | #include "permudistArma.h" 2 | 3 | 4 | SEXP permudistArma(SEXP data_, SEXP groups_, SEXP rounds_) { 5 | try { 6 | mat armaData = as(data_); 7 | arma::ivec armaGroups = Rcpp::as(groups_); 8 | int rounds = Rcpp::as(rounds_); 9 | 10 | ivec permuvec = armaGroups; 11 | int maxlev = armaGroups.max(); 12 | int alldist=0; 13 | for (int i=1; i < maxlev; ++i) 14 | alldist +=i; 15 | List out(alldist); 16 | for (int i=0; i < alldist; ++i) { 17 | NumericVector dist0(rounds+1); 18 | out[i] =dist0; 19 | } 20 | for (int i=0; i <= rounds; ++i) { 21 | int count = 0; 22 | if (i > 0) 23 | permuvec = shuffle(permuvec); 24 | for (int j0 = 1; j0 < maxlev; ++j0) { 25 | mat tmp1 = armaData.rows(arma::find(permuvec == j0 )); 26 | mat mean1 = mean(tmp1,0); 27 | for(int j1 =j0+1; j1 <= maxlev; ++j1) { 28 | mat tmp2 = armaData.rows(arma::find(permuvec == j1 )); 29 | mat mean2 = mean(tmp2,0); 30 | mat diff = mean1-mean2; 31 | double tmpdist = norm(diff,2); 32 | NumericVector dists = out[count]; 33 | dists[i] = tmpdist; 34 | out[count]=dists; 35 | count +=1; 36 | } 37 | } 38 | } 39 | return out; 40 | } catch (std::exception& e) { 41 | ::Rf_error( e.what()); 42 | } catch (...) { 43 | ::Rf_error("unknown exception"); 44 | } 45 | } 46 | -------------------------------------------------------------------------------- /man/fastKmeans.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/fastKmeans.r 3 | \name{fastKmeans} 4 | \alias{fastKmeans} 5 | \title{fast kmeans clustering for 2D or 3D point clouds} 6 | \usage{ 7 | fastKmeans(x, k, iter.max = 10, project = TRUE, threads = 0) 8 | } 9 | \arguments{ 10 | \item{x}{matrix containing coordinates or mesh3d} 11 | 12 | \item{k}{number of clusters} 13 | 14 | \item{iter.max}{maximum number of iterations} 15 | 16 | \item{project}{logical: if x is a triangular mesh, the centers will be projected onto the surface.} 17 | 18 | \item{threads}{integer number of threads to use} 19 | } 20 | \value{ 21 | returns a list containing 22 | \item{selected}{coordinates closest to the final centers} 23 | \item{centers}{cluster center} 24 | \item{class}{vector with cluster association for each coordinate} 25 | } 26 | \description{ 27 | fast kmeans clustering for 2D or 3D point clouds - with the primary purpose to get a spatially equally distributed samples 28 | } 29 | \examples{ 30 | require(Rvcg) 31 | data(humface) 32 | set.seed(42) 33 | clust <- fastKmeans(humface,k=1000,threads=1) 34 | \dontrun{ 35 | require(rgl) 36 | 37 | ## plot the cluster centers 38 | spheres3d(clust$centers) 39 | 40 | ## now look at the vertices closest to the centers 41 | wire3d(humface) 42 | spheres3d(vert2points(humface)[clust$selected,],col=2) 43 | } 44 | 45 | 46 | } 47 | -------------------------------------------------------------------------------- /man/symmetrize.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/symmetrize.r 3 | \name{symmetrize} 4 | \alias{symmetrize} 5 | \title{create a perfectly symmetric version of landmarks} 6 | \usage{ 7 | symmetrize(x, pairedLM) 8 | } 9 | \arguments{ 10 | \item{x}{k x m matrix or k x m x n array, with rows containing landmark coordinates} 11 | 12 | \item{pairedLM}{A X x 2 matrix containing the indices (rownumbers) of the 13 | paired LM. E.g. the left column contains the lefthand landmarks, while the 14 | right side contains the corresponding right hand landmarks.} 15 | } 16 | \value{ 17 | a symmetrized version of \code{x} 18 | } 19 | \description{ 20 | create a perfectly symmetric version of landmarks 21 | } 22 | \details{ 23 | the landmarks are reflected and relabled according to 24 | \code{pairedLM} and then rotated and translated onto \code{x}. 25 | Both configurations are then averaged to obtain a perfectly symmetric one. 26 | } 27 | \examples{ 28 | data(boneData) 29 | left <- c(4,6,8) 30 | right <- c(3,5,7) 31 | pairedLM <- cbind(left,right) 32 | symx <- symmetrize(boneLM[,,2],pairedLM) 33 | \dontrun{ 34 | deformGrid3d(symx,boneLM[,,2]) 35 | } 36 | } 37 | \references{ 38 | Klingenberg CP, Barluenga M, and Meyer A. 2002. Shape analysis of symmetric 39 | structures: quantifying variation among individuals and asymmetry. Evolution 40 | 56(10):1909-1920. 41 | } 42 | -------------------------------------------------------------------------------- /R/r2morphoj.r: -------------------------------------------------------------------------------- 1 | #' Export data to MorphoJ and Morphologika 2 | #' 3 | #' Export data to MorphoJ and Morphologika 4 | #' 5 | #' 6 | #' @title Export data to MorphoJ and Morphologika 7 | #' @param x 3-dimensionla array containing landmark data. E.g. the input/output 8 | #' from \code{\link{procSym}}. 9 | #' @param file character: name the output file 10 | #' @param id.string a string with ids or factors to append 11 | #' @param labels character vector specify labels to create for Morphologika 12 | #' @param labelname character: name the labels for Morphologika. 13 | #' @param \dots unused at the moment 14 | #' 15 | #' @examples 16 | #' 17 | #' if (require(shapes)) { 18 | #' r2morphoj(gorf.dat,file="gorf.dat") 19 | #' 20 | #' data <- bindArr(gorf.dat, gorm.dat, along=3) 21 | #' datalabels <- c(rep("female",dim(gorf.dat)[3]), 22 | #' rep("male",dim(gorm.dat)[3])) 23 | #' labelname <- "sex" 24 | #' r2morphologika(data, labels=datalabels, labelname= labelname, file="data.dat") 25 | #' } 26 | #' @rdname r2morphoj 27 | #' @export 28 | r2morphoj <- function(x,file,id.string=NULL) 29 | { 30 | x <- vecx(x,byrow=TRUE) 31 | if (is.null(id.string)) 32 | { 33 | if (is.null(rownames(x))) 34 | id.string <- paste(1:nrow(x)) 35 | else 36 | id.string <- rownames(x) 37 | } 38 | out <- data.frame(id.string,x,row.names=NULL) 39 | write.table(out,file=file,quote=F,row.names=FALSE,sep="\t") 40 | } 41 | -------------------------------------------------------------------------------- /man/mcNNindex.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/mcNNindex.r 3 | \name{mcNNindex} 4 | \alias{mcNNindex} 5 | \title{find nearest neighbours for 2D and 3D point clouds} 6 | \usage{ 7 | mcNNindex(target, query, cores = parallel::detectCores(), k = k, ...) 8 | } 9 | \arguments{ 10 | \item{target}{\code{k x m} matrix containing data which to search.} 11 | 12 | \item{query}{\code{l x m} matrix containing data for which to search.} 13 | 14 | \item{cores}{integer: amount of CPU-cores to be used. Only available on systems with OpenMP support.} 15 | 16 | \item{k}{integer: how many closest points are sought.} 17 | 18 | \item{\dots}{additional arguments - currently unused.} 19 | } 20 | \value{ 21 | \code{l x k } matrix containing indices of closest points. 22 | } 23 | \description{ 24 | find nearest neighbours for point clouds using a kd-tree search. This is just a wrapper of the function vcgKDtree from 25 | package Rvcg. Wwraps the function \code{vcgKDtree} from package 'Rvcg' (for backward compatibility ) 26 | } 27 | \examples{ 28 | 29 | require(rgl) 30 | data(nose) 31 | # find closest vertex on surface for each landmark 32 | clost <- mcNNindex(vert2points(shortnose.mesh),shortnose.lm, k=1, 33 | mc.cores=1) 34 | \dontrun{ 35 | spheres3d(vert2points(shortnose.mesh)[clost,],col=2,radius=0.3) 36 | spheres3d(shortnose.lm,radius=0.3) 37 | wire3d(shortnose.mesh) 38 | } 39 | } 40 | \seealso{ 41 | \code{\link{closemeshKD}} 42 | } 43 | -------------------------------------------------------------------------------- /man/retroDeformMesh.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/retrodeform.r 3 | \name{retroDeformMesh} 4 | \alias{retroDeformMesh} 5 | \title{symmetrize a triangular mesh} 6 | \usage{ 7 | retroDeformMesh(mesh, mat, pairedLM, hmult = 5, alpha = 0.01, rot = TRUE, 8 | lambda = 1e-08, threads = 0) 9 | } 10 | \arguments{ 11 | \item{mesh}{triangular mesh of class mesh3d} 12 | 13 | \item{mat}{matrix with bilateral landmarks} 14 | 15 | \item{pairedLM}{2-column integer matrix with the 1st columns containing row indices of left side landmarks and 2nd column the right hand landmarks} 16 | 17 | \item{hmult}{damping factor for calculating local weights which is calculated as \code{humult} times the average squared distance between a landmark and its closest neighbor (on each side).} 18 | 19 | \item{alpha}{factor controlling spacing along x-axis} 20 | 21 | \item{rot}{logical: if TRUE the deformed landmarks are rotated back onto the original ones} 22 | 23 | \item{lambda}{control parameter passed to \code{\link{tps3d}}} 24 | 25 | \item{threads}{integer: number of threads to use for TPS deform} 26 | } 27 | \value{ 28 | \item{mesh}{symmetrized mesh} 29 | \item{landmarks}{a list containing the deformed and original landmarks} 30 | } 31 | \description{ 32 | symmetrize a triangular mesh 33 | } 34 | \details{ 35 | this function performs \code{\link{retroDeform3d}} and deforms the mesh accordingly using the function \code{\link{tps3d}}. 36 | } 37 | -------------------------------------------------------------------------------- /R/kendalldist.r: -------------------------------------------------------------------------------- 1 | #' Calculates the Riemannian distance between two superimposed landmark 2 | #' configs. 3 | #' 4 | #' Calculates the Riemannian distance between two superimposed landmark 5 | #' configs. 6 | #' 7 | #' 8 | #' @param x Matrix containing landmark coordinates. 9 | #' @param y Matrix containing landmark coordinates. 10 | #' @return returns Riemannian distance 11 | #' 12 | #' @examples 13 | #' if(require(shapes)) { 14 | #' OPA <- rotonto(gorf.dat[,,1],gorf.dat[,,2]) 15 | #' kendalldist(OPA$X,OPA$Y) 16 | #' } 17 | #' @export 18 | kendalldist <- function(x,y) 19 | { 20 | m <- ncol(x) 21 | x <- scale(x, scale=FALSE) 22 | y <- scale(y, scale=FALSE) 23 | x <- x/cSize(x) 24 | y <- y/cSize(y) 25 | if (max(abs(x - y) > 0)) { 26 | if (m == 3) { 27 | eigxy <- eigen(t(x)%*%tcrossprod(y)%*%(x),symmetric = TRUE)$values 28 | signchk <- det(crossprod(y,x)) 29 | #good <- which(eigxy > 0) 30 | eigxy <- sqrt(eigxy[1:m]) 31 | eigxy[m] <- sign(signchk)*eigxy[m] 32 | rho <- acos(min(sum(eigxy[1:m]),1)) 33 | } else { 34 | ## this is copied from 'riemdist' in shapes package 35 | x <- x[,1]+(0+1i)*x[,2] 36 | y <- y[,1]+(0+1i)*y[,2] 37 | rho <- acos(min(1, (Mod(t(Conj(x)) %*% y)))) 38 | } 39 | } else 40 | rho <- 0 41 | return(rho) 42 | } 43 | -------------------------------------------------------------------------------- /R/plot.normals.r: -------------------------------------------------------------------------------- 1 | #' plots the normals of a triangular surface mesh. 2 | #' 3 | #' visualises the vertex normals of a triangular surface mesh of class mesh3d. 4 | #' If no normals are contained, they are computed. 5 | #' 6 | #' 7 | #' @param x object of class "mesh3d" 8 | #' @param long length of the normals (default is 1) 9 | #' @param lwd width of the normals 10 | #' @param col color of the normals 11 | #' @author Stefan Schlager 12 | #' 13 | #' @examples 14 | #' 15 | #' \dontrun{ 16 | #' require(rgl) 17 | #' data(nose) 18 | #' plotNormals(shortnose.mesh,col=4,long=0.01) 19 | #' shade3d(shortnose.mesh,col=3) 20 | #' } 21 | #' 22 | #' @export 23 | plotNormals <- function(x,long=1,lwd=1,col=1) 24 | { 25 | if ( ! "mesh3d" %in% class(x)) 26 | {stop("please provide object of class mesh3d") 27 | } 28 | 29 | if (is.null(x$normals)) { 30 | if (!is.null(x$it)) 31 | x <- vcgUpdateNormals(x) 32 | else 33 | stop("mesh has neither normals nor faces") 34 | } 35 | 36 | n.mesh <- list() 37 | lvb <- dim(x$vb)[2] 38 | vb <- x$vb 39 | vb.norm <- vb[1:3,,drop=FALSE]+long*x$normals[1:3,,drop=FALSE] 40 | vb <- cbind(vb[1:3,,drop=FALSE],vb.norm) 41 | vb <- rbind(vb,1) 42 | 43 | it <- rbind(1:lvb,1:lvb,(1:lvb)+lvb) 44 | n.mesh$vb <- vb 45 | n.mesh$it <- it 46 | class(n.mesh) <- c("mesh3d","shape3d") 47 | # n.mesh$primitivetype <- "triangle" 48 | wire3d(n.mesh,color=col,lwd=lwd,lit=FALSE) 49 | 50 | } 51 | 52 | 53 | -------------------------------------------------------------------------------- /src/doozers.cpp: -------------------------------------------------------------------------------- 1 | #ifndef angcal_H_ 2 | #define angcal_H_ 3 | 4 | #include 5 | #include "doozers.h" 6 | 7 | using namespace Rcpp; 8 | using namespace std; 9 | using namespace arma; 10 | 11 | double angcalcArma(vec a, vec b) { 12 | try { 13 | double alen = norm(a,2); 14 | double blen = norm(b,2); 15 | if (alen > 0) 16 | a = a/alen; 17 | if (blen > 0) 18 | b = b/blen; 19 | vec diffvec = a-b; 20 | double angle = acos((dot(diffvec,diffvec)-2)/-2); 21 | return angle; 22 | } catch (std::exception& e) { 23 | ::Rf_error( e.what()); 24 | } catch (...) { 25 | ::Rf_error("unknown exception"); 26 | } 27 | } 28 | 29 | double angcalcRcpp(NumericVector a_, NumericVector b_) { 30 | try { 31 | colvec a(a_.begin(),a_.size(),false); 32 | colvec b(b_.begin(),b_.size(),false); 33 | double alen = sqrt(dot(a,a)); 34 | double blen = sqrt(dot(b,b)); 35 | if (alen > 0) 36 | a = a/alen; 37 | if (blen > 0) 38 | b = b/blen; 39 | colvec diffvec = a-b; 40 | double angle = acos((dot(diffvec,diffvec)-2)/-2); 41 | return angle; 42 | } catch (std::exception& e) { 43 | ::Rf_error( e.what()); 44 | } catch (...) { 45 | ::Rf_error("unknown exception"); 46 | } 47 | } 48 | void crosspArma(colvec x, colvec y, colvec& z) { 49 | z(0) = x(1)*y(2)-x(2)*y(1); 50 | z(1) = x(2)*y(0)-x(0)*y(2); 51 | z(2) = x(0)*y(1)-x(1)*y(0); 52 | double lz = sqrt(dot(z,z)); 53 | if (lz > 0) 54 | z = z/lz; 55 | } 56 | #endif /*angcal_H_*/ 57 | -------------------------------------------------------------------------------- /man/anonymize.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/anonymize.r 3 | \name{anonymize} 4 | \alias{anonymize} 5 | \title{Replace ID-strings of data and associated files.} 6 | \usage{ 7 | anonymize(data, remove, path = NULL, dest.path = NULL, ext = ".ply", 8 | split = "_", levels = TRUE, prefix = NULL, suffix = NULL, 9 | sample = TRUE) 10 | } 11 | \arguments{ 12 | \item{data}{Named array, matrix or vector containing data.} 13 | 14 | \item{remove}{integer: which entry (separated by \code{split}) of the name 15 | is to be removed} 16 | 17 | \item{path}{Path of associated files to be copied to renamed versions.} 18 | 19 | \item{dest.path}{where to put renamed files.} 20 | 21 | \item{ext}{file extension of files to be renamed.} 22 | 23 | \item{split}{character: by which to split specimen-ID} 24 | 25 | \item{levels}{logical: if a removed entry is to be treated as a factor. E.g. 26 | if one specimen has a double entry, the anonymized versions will be named 27 | accordingly.} 28 | 29 | \item{prefix}{character: prefix before the alias string.} 30 | 31 | \item{suffix}{character: suffix after the alias ID-string.} 32 | 33 | \item{sample}{logical: whether to randomize alias ID-string.} 34 | } 35 | \value{ 36 | \item{data }{data with names replaced} 37 | \item{anonymkey }{map of original name and replaced name} 38 | } 39 | \description{ 40 | Replace ID-strings with for digits - e.g. for blind observer error testing. 41 | } 42 | \examples{ 43 | 44 | anonymize(iris,remove=1) 45 | 46 | 47 | } 48 | -------------------------------------------------------------------------------- /man/ply2mesh.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/file2mesh.r, R/obj2mesh.r, R/ply2mesh.r 3 | \name{file2mesh} 4 | \alias{file2mesh} 5 | \alias{obj2mesh} 6 | \alias{ply2mesh} 7 | \title{Import 3D surface mesh files} 8 | \usage{ 9 | file2mesh(filename, clean = TRUE, readcol = FALSE) 10 | 11 | obj2mesh(filename, adnormals = TRUE) 12 | 13 | ply2mesh(filename, adnormals = TRUE, readnormals = FALSE, readcol = FALSE, 14 | silent = FALSE) 15 | } 16 | \arguments{ 17 | \item{filename}{character: path to file} 18 | 19 | \item{clean}{Logical: Delete dumpfiles.} 20 | 21 | \item{readcol}{Logical: Import vertex colors (if available).} 22 | 23 | \item{adnormals}{Logical: If the file does not contain normal information, 24 | they will be calculated in R: Can take some time.} 25 | 26 | \item{readnormals}{Logical: Import vertex normals (if available), although 27 | no face information is present.} 28 | 29 | \item{silent}{logical: suppress messages.} 30 | } 31 | \value{ 32 | \item{mesh }{list of class mesh3d - see rgl manual for further details, 33 | or a matrix containing vertex information or a list containing vertex and 34 | normal information} 35 | } 36 | \description{ 37 | Import 3D surface mesh files 38 | } 39 | \details{ 40 | imports 3D mesh files and store them as an R .object of class mesh3d 41 | } 42 | \examples{ 43 | 44 | data(nose) 45 | mesh2ply(shortnose.mesh) 46 | mesh <- ply2mesh("shortnose.mesh.ply") 47 | 48 | mesh2obj(shortnose.mesh) 49 | mesh2 <- obj2mesh("shortnose.mesh.obj") 50 | } 51 | -------------------------------------------------------------------------------- /man/predictRelWarps.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/relwarps.r 3 | \name{predictRelWarps} 4 | \alias{predictRelWarps} 5 | \title{predict relative warps for data not included in the training data set} 6 | \usage{ 7 | predictRelWarps(x, newdata, noalign = FALSE) 8 | } 9 | \arguments{ 10 | \item{x}{output from \code{relWarps}} 11 | 12 | \item{newdata}{k x m x n array holding new landmark data} 13 | 14 | \item{noalign}{logical: if TRUE, data is assumed to be already aligned to training data and alignment is skipped.} 15 | } 16 | \value{ 17 | returns a list containing 18 | \item{bescores }{relative warp scores (PC-scores if \code{alpha = 0})} 19 | \item{uniscores }{uniform scores, NULL if \code{alpha = 0}} 20 | } 21 | \description{ 22 | predict relative warps for data not included in the training data set 23 | } 24 | \details{ 25 | This function aligns the new data to the mean from \code{x} and transforms it into the relative warp space computed from the training data. 26 | } 27 | \examples{ 28 | data(boneData) 29 | set.seed(42) 30 | training <- sample(1:80,size=60) 31 | rW1 <- relWarps(boneLM[,,training], alpha = -1) 32 | ## predict scores for the entire sample 33 | predAll <- predictRelWarps(rW1,boneLM) 34 | 35 | ## now compare the scores predicted scores to the original ones 36 | layout(matrix(1:4,2,2)) 37 | for (i in 1:2) { 38 | plot(rW1$bescores[,i],predAll$bescores[training,i],main=paste("RW",i)) 39 | plot(rW1$uniscores[,i],predAll$uniscores[training,i],main=paste("UC",i)) 40 | } 41 | } 42 | -------------------------------------------------------------------------------- /man/sortCurve.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/equidistantCurve.r 3 | \name{sortCurve} 4 | \alias{sortCurve} 5 | \title{sort curvepoints by using the subsequent neighbours} 6 | \usage{ 7 | sortCurve(x, k = 5, start = NULL) 8 | } 9 | \arguments{ 10 | \item{x}{k x m matrix containing the 2D or 3D coordinates} 11 | 12 | \item{k}{number of nearest neighbours to look at. Set high for very irregularly clustered curves.} 13 | 14 | \item{start}{integer: which row of x to use as a starting point. If NULL, it is assumed that the curve is open and the point where the angle between the two nearest neighbours is closest will be chosen.} 15 | } 16 | \value{ 17 | \item{xsorted}{matrix with coordinates sorted along a curve} 18 | \item{index}{vector containing the sorting indices} 19 | } 20 | \description{ 21 | sort curvepoints by using the subsequent neighbours 22 | } 23 | \examples{ 24 | 25 | ## generate a curve from a polynome 26 | x <- c(32,64,96,118,126,144,152.5,158) 27 | y <- c(99.5,104.8,108.5,100,86,64,35.3,15) 28 | fit <- lm(y~poly(x,2,raw=TRUE)) 29 | xx <- seq(30,160, length=50) 30 | layout(matrix(1:3,3,1)) 31 | curve <- cbind(xx,predict(fit, data.frame(x=xx))) 32 | ## permute order 33 | set.seed(42) 34 | plot(curve);lines(curve) 35 | curveunsort <- curve[sample(1:50),] 36 | ## now the curve is scrambled 37 | plot(curveunsort);lines(curveunsort,col=2) 38 | curvesort <- sortCurve(curveunsort) 39 | ## after sorting lines are nice again 40 | plot(curvesort$xsorted);lines(curvesort$xsorted,col=3) 41 | } 42 | -------------------------------------------------------------------------------- /man/projRead.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/projRead.r 3 | \name{projRead} 4 | \alias{projRead} 5 | \title{Project points onto the closest point on a mesh} 6 | \usage{ 7 | projRead(lm, mesh, readnormals = TRUE, smooth = FALSE, sign = TRUE, ...) 8 | } 9 | \arguments{ 10 | \item{lm}{m x 3 matrix containing 3D coordinates.} 11 | 12 | \item{mesh}{character: specify path to mesh file.} 13 | 14 | \item{readnormals}{logical: return normals of projected points.} 15 | 16 | \item{smooth}{logical: rerturn smoothed normals.} 17 | 18 | \item{sign}{logical: request signed distances.} 19 | 20 | \item{\dots}{additional arguments currently not used.} 21 | } 22 | \value{ 23 | if readnormals = FALSE, a m x 3 matrix containing projected points 24 | is returned, otherwise a list, where 25 | \item{vb }{3 x m matrix containing projected points} 26 | \item{normals }{3 x m matrix containing normals} 27 | \item{quality }{vector containing distances } 28 | } 29 | \description{ 30 | project points onto a given surface and return projected points and normals. 31 | } 32 | \examples{ 33 | 34 | 35 | data(nose) 36 | \dontrun{ 37 | repro <- projRead(shortnose.lm,shortnose.mesh) 38 | } 39 | 40 | } 41 | \references{ 42 | Detection of inside/outside uses the algorithm proposed in: 43 | 44 | Baerentzen, Jakob Andreas. & Aanaes, H., 2002. Generating Signed Distance 45 | Fields From Triangle Meshes. Informatics and Mathematical Modelling. 46 | } 47 | \seealso{ 48 | \code{\link{closemeshKD}} 49 | } 50 | \author{ 51 | Stefan Schlager 52 | } 53 | -------------------------------------------------------------------------------- /man/getMeaningfulPCs.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/PCmeaning.r 3 | \name{getMeaningfulPCs} 4 | \alias{getMeaningfulPCs} 5 | \title{get number of meaningful Principal components} 6 | \usage{ 7 | getMeaningfulPCs(values, n, expect = 2, sdev = FALSE) 8 | } 9 | \arguments{ 10 | \item{values}{eigenvalues from a PCA} 11 | 12 | \item{n}{sample size} 13 | 14 | \item{expect}{expectation value for chi-square distribution of df=2} 15 | 16 | \item{sdev}{logical: if TRUE, it is assumed that the values are square roots of eigenvalues.} 17 | } 18 | \value{ 19 | \item{tol}{threshold of ratio specific for \code{n}} 20 | \item{good}{integer vector specifying the meaningful Principal Components} 21 | } 22 | \description{ 23 | get number of meaningful Principal components 24 | } 25 | \details{ 26 | This implements the method suggested by Bookstein (2014, pp. 324), to determine whether a PC is entitled to interpretation. I.e. a PC is regarded meaningful (its direction) if the ratio of this PC and its successor is above a threshold based on a log-likelihood ratio (and dependend on sample size). 27 | } 28 | \examples{ 29 | data(boneData) 30 | proc <- procSym(boneLM) 31 | getMeaningfulPCs(proc$eigenvalues,n=nrow(proc$PCscores)) 32 | ## the first 3 PCs are reported as meaningful 33 | ## show barplot that seem to fit the bill 34 | barplot(proc$eigenvalues) 35 | } 36 | \references{ 37 | Bookstein, F. L. Measuring and reasoning: numerical inference in the sciences. Cambridge University Press, 2014 38 | } 39 | \seealso{ 40 | \code{\link{getPCtol}} 41 | } 42 | -------------------------------------------------------------------------------- /man/ray2mesh.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/ray2mesh.r 3 | \name{ray2mesh} 4 | \alias{ray2mesh} 5 | \title{projects the vertices of a mesh along its normals onto the surface of another one.} 6 | \usage{ 7 | ray2mesh(mesh1, tarmesh, tol = 1e+12, inbound = FALSE, mindist = FALSE, 8 | ...) 9 | } 10 | \arguments{ 11 | \item{mesh1}{mesh to project. Can be an object of class "mesh3d" or path to 12 | an external mesh file (ply, obj, stl).} 13 | 14 | \item{tarmesh}{mesh to project onto. Can be an object of class "mesh3d" or 15 | path to an external mesh file (ply, obj, stl).} 16 | 17 | \item{tol}{numeric: maximum distance to search along ray, closest Euclidean 18 | distance will be used, if tol is exceeded.} 19 | 20 | \item{inbound}{inverse search direction along rays.} 21 | 22 | \item{mindist}{search both ways (ray and -ray) and select closest point.} 23 | 24 | \item{\dots}{additional arguments not used at the moment.} 25 | } 26 | \value{ 27 | returns projected mesh with additional list entries: 28 | \item{quality }{integer vector containing a value for each vertex of \code{x}: 1 indicates that a ray has intersected 'tarmesh' within the given threshold, while 0 means not} 29 | \item{distance }{numeric vector: distances to intersection} 30 | } 31 | \description{ 32 | projects the vertices of a mesh onto the surface of another one by searching 33 | for the closest point along vertex normals on the 34 | target by for each vertex. 35 | } 36 | \seealso{ 37 | \code{\link{ply2mesh}}, \code{\link{closemeshKD}} 38 | } 39 | \author{ 40 | Stefan Schlager 41 | } 42 | -------------------------------------------------------------------------------- /man/Morpho-package.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/Morpho-package.R 3 | \docType{package} 4 | \encoding{utf8} 5 | \name{Morpho-package} 6 | \alias{Morpho-package} 7 | \alias{Morpho} 8 | \title{A toolbox providing methods for data-acquisition, visualisation and 9 | statistical methods related to Geometric Morphometrics and shape analysis} 10 | \description{ 11 | A toolbox for Morphometric calculations. Including sliding operations for 12 | Semilandmarks, importing, exporting and manipulating of 3D-surface meshes 13 | and semi-automated placement of surface landmarks. 14 | } 15 | \details{ 16 | \tabular{ll}{ 17 | Package: \tab Morpho\cr 18 | Type: \tab Package\cr 19 | Version: \tab 2.5.1\cr 20 | Date: \tab 2017-04-19\cr 21 | License: \tab GPL\cr 22 | LazyLoad: \tab yes\cr 23 | } 24 | } 25 | \note{ 26 | The pdf-version of Morpho-help can be obtained from CRAN on \url{https://cran.r-project.org/package=Morpho} 27 | 28 | For more advanced operations on triangular surface meshes, check out my package Rvcg: \url{https://cran.r-project.org/package=Rvcg} or the code repository on github \url{https://github.com/zarquon42b/Rvcg} 29 | } 30 | \references{ 31 | Schlager S. 2013. Soft-tissue reconstruction of the human nose: 32 | population differences and sexual dimorphism. PhD thesis, 33 | \enc{Universitätsbibliothek}{Universitaetsbibliothek} Freiburg. URL: 34 | \url{http://www.freidok.uni-freiburg.de/volltexte/9181/}. 35 | } 36 | \author{ 37 | Stefan Schlager \email{zarquon42@gmail.com} 38 | 39 | Maintainer: Stefan Schlager \email{zarquon42@gmail.com} 40 | } 41 | \keyword{package} 42 | -------------------------------------------------------------------------------- /man/read.csv.folder.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/read.csv.folder.r 3 | \name{read.csv.folder} 4 | \alias{read.csv.folder} 5 | \title{batch import data from files} 6 | \usage{ 7 | read.csv.folder(folder, x, y = 2:4, rownames = NULL, header = TRUE, 8 | dec = ".", sep = ";", pattern = "csv", addSpec = NULL, back = TRUE) 9 | } 10 | \arguments{ 11 | \item{folder}{character: path to folder} 12 | 13 | \item{x}{either a vector specifiing which rows are to be imported, or 14 | character vector containing variable names to be sought for.} 15 | 16 | \item{y}{a vector specifiing, which columns of the speradsheet ist to be 17 | imported.} 18 | 19 | \item{rownames}{integer: specifies columns, where variable names are stored.} 20 | 21 | \item{header}{logical : if spreadsheet contains header-row.} 22 | 23 | \item{dec}{character: defines decimal sepearator.} 24 | 25 | \item{sep}{character: defines column seperator.} 26 | 27 | \item{pattern}{character: specify file format (e.g. csv).} 28 | 29 | \item{addSpec}{character: add a custom specifier to the dimnames of the 30 | array.} 31 | 32 | \item{back}{logical: where to place the specifier.} 33 | } 34 | \value{ 35 | \item{arr }{array containing imported data} 36 | \item{NAs }{vector containing position of observations with NAs} 37 | \item{NA.list }{list: containing vectors containing information which 38 | LMs are missing in which observation} 39 | } 40 | \description{ 41 | imports all data files contained in a specified folder. 42 | } 43 | \seealso{ 44 | \code{\link{read.table}} 45 | } 46 | \author{ 47 | Stefan Schlager 48 | } 49 | -------------------------------------------------------------------------------- /man/permudist.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/permudist.r 3 | \name{permudist} 4 | \alias{permudist} 5 | \title{performs permutation testing for group differences.} 6 | \usage{ 7 | permudist(data, groups, rounds = 1000, which = NULL, 8 | p.adjust.method = "none") 9 | } 10 | \arguments{ 11 | \item{data}{array or matrix containing data} 12 | 13 | \item{groups}{factors determining grouping.} 14 | 15 | \item{rounds}{number of permutations} 16 | 17 | \item{which}{integer (optional): in case the factor levels are > 2 this determins which factorlevels to use} 18 | 19 | \item{p.adjust.method}{method to adjust p-values for multiple comparisons see \code{\link{p.adjust.methods}} for options.} 20 | } 21 | \value{ 22 | \item{dist }{distance matrix with distances between actual group means} 23 | \item{p.adjust.method}{method used for p-value adjustion} 24 | \item{p.value }{distance matrix containing pairwise p-values obtained by comparing the actual distance to randomly acquired distances} 25 | } 26 | \description{ 27 | This function compares the distance between two groupmeans to the distances 28 | obtained by random assignment of observations to this groups. 29 | } 30 | \examples{ 31 | 32 | data(boneData) 33 | proc <- procSym(boneLM) 34 | groups <- name2factor(boneLM,which=3) 35 | perm <- permudist(proc$PCscores[,1:10], groups=groups, rounds=10000) 36 | 37 | ## now we concentrate only on sex dimorphism between Europeans 38 | groups <- name2factor(boneLM,which=3:4) 39 | levels(groups) 40 | perm1 <- permudist(proc$PCscores, groups=groups,which=3:4, rounds=10000) 41 | 42 | 43 | } 44 | -------------------------------------------------------------------------------- /R/write.pts.r: -------------------------------------------------------------------------------- 1 | #' exports a matrix containing landmarks into .pts format 2 | #' 3 | #' exports a matrix containing landmarks into .pts format that can be read by 4 | #' IDAV Landmark. 5 | #' 6 | #' you can import the information into the program landmarks available at 7 | #' http://graphics.idav.ucdavis.edu/research/EvoMorph 8 | #' 9 | #' @param x k x m matrix containing landmark configuration 10 | #' @param filename character: Path/name of the requested output - extension 11 | #' will be added atuomatically. If not specified, the file will be named as the 12 | #' exported object. 13 | #' @param rownames provide an optional character vector with rownames 14 | #' @author Stefan Schlager 15 | #' @seealso \code{\link{read.pts}} 16 | #' 17 | #' @examples 18 | #' 19 | #' data(nose) 20 | #' write.pts(shortnose.lm, filename="shortnose") 21 | #' 22 | #' @export 23 | write.pts <- function(x, filename=dataname,rownames=NULL) 24 | { 25 | dataname <- deparse(substitute(x)) 26 | if (!grepl("*.pts$",filename)) 27 | filename <- paste(filename,".pts",sep="") 28 | k <- dim(x)[1] 29 | m <- dim(x)[2] 30 | x <- as.matrix(x) 31 | if (is.null(rownames)) 32 | a0 <- paste0("S",sprintf("%04d", 0:(k-1))) 33 | else 34 | a0 <- rownames 35 | all.frame <- cbind(a0,x) 36 | all.frame <- format(all.frame,trim=TRUE) 37 | cat("Version 1.0\n",file=filename) 38 | cat(paste(k,"\n",sep=""),file=filename,append=T) 39 | write.table(all.frame,append = T,file = filename,col.names = FALSE,quote=FALSE,row.names = FALSE) 40 | #write(t(all.frame),file=filename,sep="",ncolumns = m+1,append=TRUE) 41 | } 42 | -------------------------------------------------------------------------------- /R/symmetrize.r: -------------------------------------------------------------------------------- 1 | #' create a perfectly symmetric version of landmarks 2 | #' 3 | #' create a perfectly symmetric version of landmarks 4 | #' 5 | #' @param x k x m matrix or k x m x n array, with rows containing landmark coordinates 6 | #' @param pairedLM A X x 2 matrix containing the indices (rownumbers) of the 7 | #' paired LM. E.g. the left column contains the lefthand landmarks, while the 8 | #' right side contains the corresponding right hand landmarks. 9 | #' @return a symmetrized version of \code{x} 10 | #' @details the landmarks are reflected and relabled according to 11 | #' \code{pairedLM} and then rotated and translated onto \code{x}. 12 | #' Both configurations are then averaged to obtain a perfectly symmetric one. 13 | #' @references 14 | #' Klingenberg CP, Barluenga M, and Meyer A. 2002. Shape analysis of symmetric 15 | #' structures: quantifying variation among individuals and asymmetry. Evolution 16 | #' 56(10):1909-1920. 17 | #' @examples 18 | #' data(boneData) 19 | #' left <- c(4,6,8) 20 | #' right <- c(3,5,7) 21 | #' pairedLM <- cbind(left,right) 22 | #' symx <- symmetrize(boneLM[,,2],pairedLM) 23 | #' \dontrun{ 24 | #' deformGrid3d(symx,boneLM[,,2]) 25 | #' } 26 | #' @export 27 | symmetrize <- function(x, pairedLM) { 28 | if (length(dim(x)) == 3) { 29 | for (i in 1:dim(x)[3]) 30 | x[,,i] <- symmetrize(x[,,i],pairedLM=pairedLM) 31 | xsym <- x 32 | } else { 33 | xmir <- mirror(x,icpiter=0) 34 | xmir[c(pairedLM),] <- xmir[c(pairedLM[,2:1]),] 35 | xrot <- rotonto(x,xmir,reflection = FALSE)$yrot 36 | xsym <- (x+xrot)/2 37 | } 38 | return(xsym) 39 | } 40 | 41 | -------------------------------------------------------------------------------- /R/rot.proc.r: -------------------------------------------------------------------------------- 1 | rot.proc <- function(x, y, scale=TRUE, weights=NULL, centerweight=FALSE, reflection=TRUE) { 2 | 3 | if (centerweight && !is.null(weights)) { 4 | xcent <- apply(x,2,weighted.mean,w=weights) 5 | ycent <- apply(y,2,weighted.mean,w=weights) 6 | x <- scale(x,scale=F,center=xcent) 7 | y <- scale(y,scale=F,center=ycent) 8 | } 9 | ### rotates 2 already centred matrices onto each other# 10 | if (!is.null(weights)) { 11 | Dn <- diag(weights) 12 | X1 <- Dn%*%x 13 | Y1 <- Dn%*%y 14 | XY <- crossprod(X1,Y1) 15 | } else 16 | XY <- crossprod(x,y) 17 | 18 | sv1 <- svd(XY) 19 | gamm <- tcrossprod(sv1$v,sv1$u) 20 | if (sign(det(gamm)) < 1 && !reflection) { 21 | if (!reflection) { 22 | u <- sv1$u 23 | v <- sv1$v 24 | chk1 <- Re(prod(eigen(v)$values)) 25 | chk2 <- Re(prod(eigen(u)$values)) 26 | if ((chk1 < 0) && (chk2 > 0)) { 27 | v[, dim(v)[2]] <- v[, dim(v)[2]] * (-1) 28 | gamm <- v %*% t(u) 29 | } 30 | if ((chk2 < 0) && (chk1 > 0)) { 31 | u[, dim(u)[2]] <- u[, dim(u)[2]] * (-1) 32 | gamm <- v %*% t(u) 33 | } 34 | } 35 | } 36 | del <- sv1$d 37 | ctrace <- function(MAT) sum(diag(crossprod(MAT))) 38 | if (scale) { 39 | 40 | if (!is.null(weights)) 41 | bet <- sum(del)/ctrace(Y1) 42 | else 43 | bet <- sum(del)/ctrace(y) 44 | yrot <- bet*y%*%gamm} 45 | else 46 | yrot <- y%*%gamm 47 | return(yrot) 48 | } 49 | -------------------------------------------------------------------------------- /R/tanplan.r: -------------------------------------------------------------------------------- 1 | #' calculate the orthogonal complement of a 3D-vector 2 | #' 3 | #' calculate the orthogonal complement of a 3D-vector or the 3D-crossproduct, 4 | #' finding an orthogonal vector to a plane in 3D. 5 | #' 6 | #' 7 | #' @title calculate the orthogonal complement of a 3D-vector 8 | #' @param x vector of length 3. 9 | #' @param y vector of length 3. 10 | #' @return tangentPlane: 11 | #' 12 | #' crossProduct: returns a vector of length 3. 13 | #' \item{y }{vector orthogonal to x} 14 | #' \item{z }{vector orthogonal to x and y} 15 | #' @author Stefan Schlager 16 | #' @examples 17 | #' 18 | #' require(rgl) 19 | #' 20 | #' x <- c(1,0,0) 21 | #' y <- c(0,1,0) 22 | #' 23 | #' #example tangentPlane 24 | #' z <- tangentPlane(x) 25 | #' #visualize result 26 | #' \dontrun{ 27 | #' lines3d(rbind(0, x), col=2, lwd=2) 28 | #' ## show complement 29 | #' lines3d(rbind(z$y, 0, z$z), col=3, lwd=2) 30 | #' } 31 | #' # example crossProduct 32 | #' z <- crossProduct(x, y) 33 | #' # show x and y 34 | #' \dontrun{ 35 | #' lines3d(rbind(x, 0, y), col=2, lwd=2) 36 | #' # show z 37 | #' lines3d(rbind(0, z), col=3, lwd=2) 38 | #' } 39 | #' @rdname tangentPlane 40 | #' @export 41 | tangentPlane <- function(x) 42 | { if (sum(x^2)==0) 43 | {stop(cat("zero vector has no orthogonal subspace"))} 44 | 45 | 46 | 47 | if (0 %in% x) 48 | { 49 | y <- c(0,0,0) 50 | y[which(x==0)] <- 1 51 | y <- y/sqrt(sum(y^2)) 52 | } 53 | else 54 | { 55 | y <- c(1,1,-(x[1]+x[2])/x[3]) 56 | y <- y/sqrt(sum(y^2)) 57 | } 58 | z <- crossProduct(y,x) 59 | z <- z/sqrt(sum(z^2)) 60 | return(list(z=z,y=y)) 61 | } 62 | 63 | 64 | -------------------------------------------------------------------------------- /R/solutionSpace.r: -------------------------------------------------------------------------------- 1 | #' returns the solution space (basis and translation vector) for an equation system 2 | #' 3 | #' returns the solution space (basis and translation vector) for an equation system 4 | #' 5 | #' @param A numeric matrix 6 | #' @param b numeric vector 7 | #' 8 | #' @return 9 | #' \item{basis}{matrix containing the basis of the solution space} 10 | #' \item{translate}{translation vector} 11 | #' 12 | #' @details For a linear equationsystem, \eqn{Ax = b}{Ax = b}, the solution space then is 13 | #' \deqn{x = A^* b + (I - A^* A) y}{x = A'b + (I - A' A)} 14 | #' where \eqn{A^*}{A'} is the Moore-Penrose pseudoinverse of \eqn{A}{A}. 15 | #' The QR decomposition of \eqn{I - A^* A}{I - A'A} determines the dimension of and basis of the solution space. 16 | #'@examples 17 | #' A <- matrix(rnorm(21),3,7) 18 | #' b <- c(1,2,3) 19 | #' subspace <- solutionSpace(A,b) 20 | #' dims <- ncol(subspace$basis) # we now have a 4D solution space 21 | #' ## now pick any vector from this space. E.g 22 | #' y <- 1:dims 23 | #' solution <- subspace$basis%*%y+subspace$translate # this is one solution for the equation above 24 | #' A%*%solution ## pretty close 25 | #' @export 26 | solutionSpace <- function(A,b){ 27 | Apinv <- armaGinv(A) 28 | translate <- c(Apinv%*%b) 29 | basis <- Apinv%*%A 30 | if (isTRUE(all.equal(diag(ncol(A)),basis))) { 31 | basis <- matrix(0,ncol(A),0) 32 | } else { 33 | basis <- -basis 34 | diag(basis) <- 1+diag(basis) 35 | qrcheck <- qr(basis) 36 | basis <- qr.Q(qrcheck)[,1:qrcheck$rank,drop=FALSE] 37 | } 38 | out <- list(basis=basis,translate=translate) 39 | return(out) 40 | } 41 | -------------------------------------------------------------------------------- /man/procAOVsym.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/procAOVsym.r 3 | \name{procAOVsym} 4 | \alias{procAOVsym} 5 | \title{Procrustes ANOVA for structures with object symmetry} 6 | \usage{ 7 | procAOVsym(symproc, indnames = NULL) 8 | } 9 | \arguments{ 10 | \item{symproc}{object returned by \code{\link{procSym}}, where 11 | \code{pairedLM} is specified} 12 | 13 | \item{indnames}{vector containing specimen identifiers. Only necessary, if 14 | data does not contain dimnames containing identifiers} 15 | } 16 | \value{ 17 | returns a dataframe containing Sums of Squares for each factor. 18 | } 19 | \description{ 20 | Procrustes ANOVA for structures with object symmetry, currently only 21 | supporting the factors 'specimen', 'side' and the interaction term. 22 | } 23 | \details{ 24 | performs a Procrustes ANOVA for configurations with object symmetry (as 25 | described in Klingenberg et al. 2002). 26 | } 27 | \note{ 28 | In future releases the implementation of support for bilateral 29 | symmetry and more factors is intended. 30 | } 31 | \examples{ 32 | 33 | data(boneData) 34 | left <- c(4,6,8) 35 | ## determine corresponding Landmarks on the right side: 36 | # important: keep same order 37 | right <- c(3,5,7) 38 | pairedLM <- cbind(left,right) 39 | symproc <- procSym(boneLM, pairedLM=pairedLM) 40 | procAOVsym(symproc) 41 | 42 | } 43 | \references{ 44 | Klingenberg CP, Barluenga M, Meyer A. 2002. Shape analysis of 45 | symmetric structures: quantifying variation among individuals and asymmetry. 46 | Evolution 56:1909-20. 47 | } 48 | \seealso{ 49 | \code{\link{procSym}} 50 | } 51 | \author{ 52 | Stefan Schlager 53 | } 54 | -------------------------------------------------------------------------------- /R/scalemesh.r: -------------------------------------------------------------------------------- 1 | #' scale a mesh of class "mesh3d" 2 | #' 3 | #' scales (the vertices of a mesh by a scalar 4 | #' 5 | #' The mesh's center is determined either as mean of the bounding box 6 | #' (center="bbox") or mean of vertex coordinates (center="mean") and then 7 | #' scaled according to the scaling factor. If center="none", vertex coordinates 8 | #' will simply be multiplied by "size". 9 | #' 10 | #' @param mesh object of class "mesh3d" 11 | #' @param size numeric: scale factor 12 | #' @param center character: method to position center of mesh after scaling: 13 | #' values are "bbox", and "mean". See Details for more info. 14 | #' @return returns a scaled mesh 15 | #' @author Stefan Schlager 16 | #' @seealso \code{\link{rotmesh.onto}} 17 | #' 18 | #' @examples 19 | #' 20 | #' data(nose) 21 | #' #inflate mesh by factor 4 22 | #' largenose <- scalemesh(shortnose.mesh,4) 23 | #' 24 | #' @export 25 | scalemesh <- function(mesh,size,center=c("bbox","mean", "none")) 26 | { 27 | getmean <- TRUE 28 | if (substr(center[1],1L,1L) =="b") 29 | meshmean <- colMeans(meshcube(mesh)) 30 | else if (substr(center[1],1L,1L) =="m") 31 | meshmean <- colMeans(vert2points(mesh)) 32 | else if (substr(center[1],1L,1L) =="n") 33 | getmean <- FALSE 34 | else 35 | stop("Please provide valid centering method\n") 36 | if (getmean) 37 | { 38 | mesh <- translate3d(mesh,-meshmean[1],-meshmean[2],-meshmean[3]) 39 | mesh$vb[1:3,] <- mesh$vb[1:3,]*size 40 | mesh <- translate3d(mesh,meshmean[1],meshmean[2],meshmean[3]) 41 | } 42 | else 43 | mesh$vb[1:3,] <- mesh$vb[1:3,]*size 44 | return(mesh) 45 | } 46 | 47 | -------------------------------------------------------------------------------- /man/rotaxis3d.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/rotaxis.r 3 | \name{rotaxis3d} 4 | \alias{rotaxis3d} 5 | \alias{rotaxis3d.matrix} 6 | \alias{rotaxis3d.mesh3d} 7 | \title{Rotate an object (matrix or mesh) around an arbitrary axis in 3D} 8 | \usage{ 9 | rotaxis3d(x, pt1, pt2 = c(0, 0, 0), theta) 10 | 11 | \method{rotaxis3d}{matrix}(x, pt1, pt2 = c(0, 0, 0), theta) 12 | 13 | \method{rotaxis3d}{mesh3d}(x, pt1, pt2 = c(0, 0, 0), theta) 14 | } 15 | \arguments{ 16 | \item{x}{k x 3 matrix containing 3D-coordinates or a triangular mesh of 17 | class "mesh3d".} 18 | 19 | \item{pt1}{numeric vector of length 3, defining first point on the rotation 20 | axis.} 21 | 22 | \item{pt2}{numeric vector of length 3, defining second point on the rotation 23 | axis.} 24 | 25 | \item{theta}{angle to rotate in radians. With pt1 being the viewpoint, the 26 | rotation is counterclockwise.} 27 | } 28 | \value{ 29 | returns rotated object (including updated normals for mesh3d 30 | objects) 31 | } 32 | \description{ 33 | Rotate an object around an arbitrary axis in 3D 34 | } 35 | \details{ 36 | Rotate an object (matrix or triangular mesh) around an 3D-axis defined by 37 | two points. 38 | } 39 | \examples{ 40 | 41 | require(rgl) 42 | data(nose) 43 | shrot.rot <- rotaxis3d(shortnose.mesh,pt1=c(1,1,1),theta=pi) 44 | \dontrun{ 45 | shade3d(shortnose.mesh,col=3,specular=1) 46 | shade3d(shrot.rot,col=2) 47 | 48 | ###print rotation axis 49 | #' lines3d(rbind(rep(-0.1,3),rep(0.1,3))) 50 | } 51 | } 52 | \references{ 53 | http://en.wikipedia.org/wiki/Rotation_matrix 54 | } 55 | \seealso{ 56 | \code{\link{rotonto}}, \code{\link{rotmesh.onto}} 57 | } 58 | \author{ 59 | Stefan Schlager 60 | } 61 | -------------------------------------------------------------------------------- /man/updateNormals.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/updateNormals.r 3 | \name{updateNormals} 4 | \alias{updateNormals} 5 | \alias{facenormals} 6 | \title{Compute face or vertex normals of a triangular mesh} 7 | \usage{ 8 | updateNormals(x, angle = TRUE) 9 | 10 | facenormals(x) 11 | } 12 | \arguments{ 13 | \item{x}{triangular mesh of class "mesh3d"} 14 | 15 | \item{angle}{logical: if TRUE, angle weighted normals are used.} 16 | } 17 | \value{ 18 | \code{updateNormals} returns mesh with updated vertex normals. 19 | 20 | \code{facenormals} returns an object of class "mesh3d" with 21 | \item{vb }{faces' barycenters} 22 | \item{normals }{faces' normals} 23 | } 24 | \description{ 25 | Compute face or vertex normals of a triangular mesh of class "mesh3d" 26 | } 27 | \note{ 28 | only supports triangular meshes 29 | } 30 | \examples{ 31 | 32 | require(rgl) 33 | require(Morpho) 34 | data(nose) 35 | ### calculate vertex normals 36 | shortnose.mesh$normals <- NULL ##remove normals 37 | \dontrun{ 38 | shade3d(shortnose.mesh,col=3)##render 39 | } 40 | shortnose.mesh <- updateNormals(shortnose.mesh) 41 | \dontrun{ 42 | rgl.clear() 43 | shade3d(shortnose.mesh,col=3)##smoothly rendered now 44 | } 45 | ## calculate facenormals 46 | facemesh <- facenormals(shortnose.mesh) 47 | \dontrun{ 48 | plotNormals(facemesh,long=0.01) 49 | points3d(vert2points(facemesh),col=2) 50 | wire3d(shortnose.mesh) 51 | } 52 | } 53 | \references{ 54 | Baerentzen, Jakob Andreas. & Aanaes, H., 2002. Generating Signed 55 | Distance Fields From Triangle Meshes. Informatics and Mathematical 56 | Modelling, . 57 | } 58 | \seealso{ 59 | \code{\link{ply2mesh}} 60 | } 61 | \author{ 62 | Stefan Schlager 63 | } 64 | -------------------------------------------------------------------------------- /R/projRead.r: -------------------------------------------------------------------------------- 1 | #' Project points onto the closest point on a mesh 2 | #' 3 | #' project points onto a given surface and return projected points and normals. 4 | #' 5 | #' 6 | #' @param lm m x 3 matrix containing 3D coordinates. 7 | #' @param mesh character: specify path to mesh file. 8 | #' @param readnormals logical: return normals of projected points. 9 | #' @param smooth logical: rerturn smoothed normals. 10 | #' @param sign logical: request signed distances. 11 | #' @param \dots additional arguments currently not used. 12 | #' @return if readnormals = FALSE, a m x 3 matrix containing projected points 13 | #' is returned, otherwise a list, where 14 | #' \item{vb }{3 x m matrix containing projected points} 15 | #' \item{normals }{3 x m matrix containing normals} 16 | #' \item{quality }{vector containing distances } 17 | #' @author Stefan Schlager 18 | #' @seealso \code{\link{closemeshKD}} 19 | #' @references Detection of inside/outside uses the algorithm proposed in: 20 | #' 21 | #' Baerentzen, Jakob Andreas. & Aanaes, H., 2002. Generating Signed Distance 22 | #' Fields From Triangle Meshes. Informatics and Mathematical Modelling. 23 | #' 24 | #' @examples 25 | #' 26 | #' 27 | #' data(nose) 28 | #' \dontrun{ 29 | #' repro <- projRead(shortnose.lm,shortnose.mesh) 30 | #' } 31 | #' 32 | #' @importFrom Rvcg vcgClost vcgImport 33 | #' @export 34 | projRead <- function(lm, mesh,readnormals=TRUE, smooth=FALSE, sign=TRUE,...) 35 | { 36 | if (is.character(mesh)) 37 | mesh <- vcgImport(mesh,updateNormals=FALSE,clean=FALSE) 38 | 39 | data <- vcgClost(lm, mesh, smoothNormals=smooth,sign=sign,borderchk=FALSE) 40 | if (!readnormals) 41 | data <- vert2points(data) 42 | return(data) 43 | } 44 | -------------------------------------------------------------------------------- /R/r2morphologika.r: -------------------------------------------------------------------------------- 1 | #' @rdname r2morphoj 2 | #' @export 3 | r2morphologika <- function(x,file=file,labels=NULL,labelname=NULL,...) 4 | { 5 | n <- dim(x)[3] 6 | m <- dim(x)[2] 7 | k <- dim(x)[1] 8 | idnames <- dimnames(x)[[3]] 9 | if (is.null(idnames)) 10 | idnames <- paste("specimen",1:n) 11 | 12 | ## start writing to file 13 | cat("[individuals]\r\n",file = file,sep="") 14 | cat(paste(n,"\r\n",sep=""),file = file,append=TRUE,sep="") 15 | cat("[landmarks]\r\n",file = file,append=TRUE,sep="") 16 | cat(paste(k,"\r\n",sep=""),file = file,append=TRUE,sep="") 17 | cat("[dimensions]\r\n",file = file,append=TRUE,sep="") 18 | cat(paste(m,"\r\n",sep=""),file = file,append=TRUE,sep="") 19 | cat("[names]\r\n",file = file,append=TRUE,sep="") 20 | cat(paste(idnames,"\r\n",sep=""),file = file,append=TRUE,sep="") 21 | if (!is.null(labels)) 22 | { 23 | cat("[labels]\r\n",file = file,append=TRUE,sep="") 24 | if (is.null(labelname)) 25 | labelname <- as.character(bquote(labels)) 26 | cat(paste(labelname,"\r\n",sep=""),file = file,append=TRUE,sep="") 27 | cat("[labelvalues]\r\n",file = file,append=TRUE,sep="") 28 | cat(paste(labels,"\r\n",sep=""),file = file,append=TRUE,sep="") 29 | } 30 | 31 | cat("[rawpoints]\r\n",file = file,append=TRUE,sep="") 32 | for (i in 1:n) 33 | { 34 | cat(paste("\'#",i,"\r\n",sep=""),file = file,append=TRUE,sep="") 35 | write.table(format(x[,,i], scientific = F, trim = T), file = file, sep = " ", append = TRUE, quote = FALSE, row.names = FALSE, col.names = FALSE, na = "", eol="\r\n") 36 | 37 | } 38 | 39 | } 40 | 41 | 42 | -------------------------------------------------------------------------------- /src/tpsfx.cpp: -------------------------------------------------------------------------------- 1 | #include 2 | #ifdef _OPENMP 3 | #include 4 | #endif 5 | using namespace Rcpp; 6 | using namespace std; 7 | using namespace arma; 8 | 9 | RcppExport SEXP tpsfx(SEXP refmat_, SEXP M_, SEXP coefs_, SEXP threads_ = wrap(1)) { 10 | try { 11 | typedef unsigned int uint; 12 | // reference coordinates 13 | mat refmat = as(refmat_); 14 | //M contains homogenous coordinates 15 | mat M = as(M_); 16 | uint lmdim = M.n_cols-1; 17 | uvec select(lmdim); 18 | for (uint i = 0; i < lmdim; i++) 19 | select[i] = i+1; 20 | // remove leading 1 from homogenous coordinates 21 | mat Mnohom = M.cols(select); 22 | mat coefs = as(coefs_); 23 | uint m = refmat.n_rows; 24 | int threads = as(threads_); 25 | // remove affine coefficients 26 | mat coefsNoAff = coefs.cols(0, m-1); 27 | mat result(M.n_rows,coefs.n_rows); result.zeros(); 28 | 29 | #pragma omp parallel for schedule(static) num_threads(threads) 30 | 31 | for (uint i=0; i < Mnohom.n_rows; ++i) { 32 | colvec x(m); 33 | for (uint j=0; j < m; ++j) { 34 | mat tmp = refmat.row(j) - Mnohom.row(i); 35 | if (lmdim > 2) { 36 | x(j) = -sqrt(dot(tmp,tmp)); 37 | } else { 38 | double tmp0 = dot(tmp,tmp); 39 | if (tmp0 == 0) 40 | x(j) = 0; 41 | else 42 | x(j) = tmp0*log(tmp0); 43 | } 44 | } 45 | vec tmp = coefsNoAff*x; 46 | vec tmpres = coefs.cols(m,m+lmdim)*M.row(i).t(); 47 | result.row(i) = (tmp+tmpres).t(); 48 | } 49 | return wrap(result); 50 | } catch (std::exception& e) { 51 | ::Rf_error( e.what()); 52 | } catch (...) { 53 | ::Rf_error("unknown exception"); 54 | } 55 | } 56 | -------------------------------------------------------------------------------- /src/tweakU.cpp: -------------------------------------------------------------------------------- 1 | #include 2 | using namespace Rcpp; 3 | using std::vector; 4 | 5 | void testandpush(vector& rows, vector& cols, vector& x, double testit, int r, int c) { 6 | if (testit != 0) { 7 | rows.push_back(r); 8 | cols.push_back(c); 9 | x.push_back(testit); 10 | } 11 | } 12 | 13 | RcppExport SEXP tweakU(SEXP tanvec_, SEXP m_, SEXP type_, SEXP SMsort_) { 14 | try { 15 | NumericMatrix tanvec(tanvec_); 16 | IntegerVector SMsort(SMsort_); 17 | int m = as(m_); 18 | int type = as(type_); 19 | int k = tanvec.rows(); 20 | std::vector rows, cols; 21 | std::vector x; 22 | for (int i = 0; i < m; i++) { 23 | testandpush(rows,cols,x,tanvec(SMsort[i]-1,0),SMsort[i],i); 24 | testandpush(rows,cols,x,tanvec(SMsort[i]-1,1),k+SMsort[i],i); 25 | testandpush(rows,cols,x,tanvec(SMsort[i]-1,2),2*k+SMsort[i],i); 26 | if (type == 1 || type == 2) { 27 | testandpush(rows,cols,x,tanvec(SMsort[i]-1,3),SMsort[i],i+m); 28 | testandpush(rows,cols,x,tanvec(SMsort[i]-1,4),k+SMsort[i],i+m); 29 | testandpush(rows,cols,x,tanvec(SMsort[i]-1,5),2*k+SMsort[i],i+m); 30 | } 31 | if (type == 2) { 32 | testandpush(rows,cols,x,tanvec(SMsort[i]-1,6),SMsort[i],i+2*m); 33 | testandpush(rows,cols,x,tanvec(SMsort[i]-1,7),k+SMsort[i],i+2*m); 34 | testandpush(rows,cols,x,tanvec(SMsort[i]-1,8),2*k+SMsort[i],i+2*m); 35 | } 36 | } 37 | return List::create(Named("rows") = rows, 38 | Named("cols") = cols, 39 | Named("x") = x 40 | ); 41 | } catch (std::exception& e) { 42 | ::Rf_error( e.what()); 43 | } catch (...) { 44 | ::Rf_error("unknown exception"); 45 | } 46 | } 47 | 48 | 49 | 50 | -------------------------------------------------------------------------------- /R/ray2mesh.r: -------------------------------------------------------------------------------- 1 | #' projects the vertices of a mesh along its normals onto the surface of another one. 2 | #' 3 | #' projects the vertices of a mesh onto the surface of another one by searching 4 | #' for the closest point along vertex normals on the 5 | #' target by for each vertex. 6 | #' 7 | #' @param mesh1 mesh to project. Can be an object of class "mesh3d" or path to 8 | #' an external mesh file (ply, obj, stl). 9 | #' @param tarmesh mesh to project onto. Can be an object of class "mesh3d" or 10 | #' path to an external mesh file (ply, obj, stl). 11 | #' @param tol numeric: maximum distance to search along ray, closest Euclidean 12 | #' distance will be used, if tol is exceeded. 13 | #' @param inbound inverse search direction along rays. 14 | #' @param mindist search both ways (ray and -ray) and select closest point. 15 | #' @param \dots additional arguments not used at the moment. 16 | #' @return returns projected mesh with additional list entries: 17 | #' \item{quality }{integer vector containing a value for each vertex of \code{x}: 1 indicates that a ray has intersected 'tarmesh' within the given threshold, while 0 means not} 18 | #' \item{distance }{numeric vector: distances to intersection} 19 | #' @author Stefan Schlager 20 | #' @seealso \code{\link{ply2mesh}}, \code{\link{closemeshKD}} 21 | #' @importFrom Rvcg vcgRaySearch vcgImport 22 | #' @export 23 | ray2mesh <- function(mesh1, tarmesh, tol=1e12, inbound=FALSE, mindist=FALSE,...) 24 | { 25 | if (is.character(tarmesh)) 26 | tarmesh <- vcgImport(tarmesh,clean=FALSE,updateNormals=FALSE) 27 | if (inbound) 28 | mesh1$normals <- -mesh1$normals 29 | outmesh <- vcgRaySearch(mesh1,tarmesh,mindist=mindist,maxtol=tol) 30 | return(outmesh) 31 | } 32 | -------------------------------------------------------------------------------- /man/getPCtol.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/PCmeaning.r 3 | \name{getPCtol} 4 | \alias{getPCtol} 5 | \title{determine the minimum ratio for two subsequent eigenvalues to be considered different} 6 | \usage{ 7 | getPCtol(n, expect = 2) 8 | } 9 | \arguments{ 10 | \item{n}{sample size} 11 | 12 | \item{expect}{expectation value for chi-square distribution of df=2} 13 | } 14 | \value{ 15 | returns the minimum ratio between two subsequent subsequent eigenvalues to be considered different. 16 | } 17 | \description{ 18 | determine the minimum ratio for two subsequent eigenvalues to be considered different 19 | } 20 | \examples{ 21 | ## reproduce the graph from Bookstein (2014, p. 324) 22 | ## and then compare it to ratios for values to be considered 23 | ## statistically significant 24 | myseq <- seq(from=10,to = 50, by = 2) 25 | myseq <- c(myseq,seq(from=50,to=1000, by =20)) 26 | ratios <- getPCtol(myseq) 27 | plot(log(myseq),ratios,cex=0,xaxt = "n",ylim=c(1,5.2)) 28 | ticks <- c(10,20,50,100,200,300,400,500,600,700,800,900,1000) 29 | axis(1,at=log(ticks),labels=ticks) 30 | lines(log(myseq),ratios) 31 | abline(v=log(ticks), col="lightgray", lty="dotted") 32 | abline(h=seq(from=1.2,to=5, by = 0.2), col="lightgray", lty="dotted") 33 | 34 | ## now we raise the bar and compute the ratios for values 35 | ## to be beyond the 95th percentile of 36 | ## the corresponding chi-square distribution: 37 | ratiosSig <- getPCtol(myseq,expect=qchisq(0.95,df=2)) 38 | lines(log(myseq),ratiosSig,col=2) 39 | 40 | 41 | } 42 | \references{ 43 | Bookstein, F. L. Measuring and reasoning: numerical inference in the sciences. Cambridge University Press, 2014 44 | } 45 | \seealso{ 46 | \code{\link{getMeaningfulPCs}} 47 | } 48 | -------------------------------------------------------------------------------- /man/CAC.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/CAC.r 3 | \name{CAC} 4 | \alias{CAC} 5 | \title{calculate common allometric component} 6 | \usage{ 7 | CAC(x, size, groups = NULL, log = FALSE) 8 | } 9 | \arguments{ 10 | \item{x}{datamatrix (e.g. with PC-scores) or 3D-array with landmark coordinates} 11 | 12 | \item{size}{vector with Centroid sizes} 13 | 14 | \item{groups}{grouping variable} 15 | 16 | \item{log}{logical: use \code{log(size)}} 17 | } 18 | \value{ 19 | \item{CACscores}{common allometric component scores} 20 | \item{CAC}{common allometric component} 21 | \item{x}{(group-) centered data} 22 | \item{sc}{CAC reprojected into original space by applying \code{CAC \%*\% x}} 23 | \item{RSCscores}{residual shape component scores} 24 | \item{RSC}{residual shape components} 25 | \item{gmeans}{groupmeans} 26 | \item{CS}{the centroid sizes (log transformed if \code{log = TRUE})} 27 | } 28 | \description{ 29 | calculate common allometric component 30 | } 31 | \examples{ 32 | data(boneData) 33 | proc <- procSym(boneLM) 34 | pop.sex <- name2factor(boneLM,which=3:4) 35 | cac <- CAC(proc$rotated,proc$size,pop.sex) 36 | plot(cac$CACscores,cac$size)#plot scores against Centroid size 37 | cor.test(cac$CACscores,cac$size)#check for correlation 38 | #visualize differences between large and small on the sample's consensus 39 | \dontrun{ 40 | large <- showPC(max(cac$CACscores),cac$CAC,proc$mshape) 41 | small <- showPC(min(cac$CACscores),cac$CAC,proc$mshape) 42 | deformGrid3d(small,large,ngrid=0) 43 | } 44 | } 45 | \references{ 46 | Mitteroecker P, Gunz P, Bernhard M, Schaefer K, Bookstein FL. 2004. Comparison of cranial ontogenetic trajectories among great apes and humans. Journal of Human Evolution 46(6):679-97. 47 | } 48 | -------------------------------------------------------------------------------- /R/cExtract.r: -------------------------------------------------------------------------------- 1 | #' extract information about fixed landmarks, curves and patches from and atlas 2 | #' generated by "landmark" 3 | #' 4 | #' After exporting the pts file of the atlas from "landmark" and importing it 5 | #' into R via "read.pts" cExtract gets information which rows of the landmark 6 | #' datasets belong to curves or patches. 7 | #' 8 | #' 9 | #' @param pts.file either a character naming the path to a pts.file or the name 10 | #' of an object imported via read.pts. 11 | #' @return returns a list containing the vectors with the indices of matrix 12 | #' rows belonging to the in "landmark" defined curves, patches and fix 13 | #' landmarks and a matrix containing landmark coordinates. 14 | #' @author Stefan Schlager 15 | #' @seealso \code{\link{read.lmdta}} ,\code{\link{read.pts}} 16 | #' @export 17 | cExtract <- function(pts.file) 18 | { 19 | if (is.character(pts.file)) 20 | x <- read.pts(pts.file) 21 | else 22 | x <- pts.file 23 | 24 | allnames <- row.names(x) 25 | cs <- grep("C",allnames) 26 | ps <- grep("P",allnames) 27 | S <- grep("S",allnames) 28 | 29 | if (length(ps)) 30 | cs <- c(cs,ps) 31 | if (length(cs)) { 32 | cnames <- row.names(x)[cs] 33 | olevels <- levels(as.factor(substr(cnames,1,4))) 34 | } else { 35 | warning("no curves or patches found") 36 | olevels <- NULL 37 | } 38 | S <- grep("S",allnames) 39 | if (!length(S)) { 40 | S <- NULL 41 | } else { 42 | S <- "S" 43 | } 44 | olevels <- c(S, olevels) 45 | tl <- length(olevels) 46 | 47 | out <- list() 48 | for (i in 1:tl) 49 | out[[olevels[i]]] <- grep(olevels[i],allnames) 50 | 51 | out$coords <- x 52 | return(out) 53 | } 54 | -------------------------------------------------------------------------------- /man/plsCoVarCommonShape.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/pls2B.r 3 | \name{plsCoVarCommonShape} 4 | \alias{plsCoVarCommonShape} 5 | \title{Compute the shape changes along the common axis of deformations} 6 | \usage{ 7 | plsCoVarCommonShape(pls, i, sdcommon = 1) 8 | } 9 | \arguments{ 10 | \item{pls}{object of class "pls2B"} 11 | 12 | \item{i}{integer: dimension of latent space to show shape changes for} 13 | 14 | \item{sdcommon}{standard deviations derived from scores scaled to a consensus scale} 15 | } 16 | \value{ 17 | returns an k x m x 2 array with the common shape changes associated with +-\code{sdcommon} SD of the \code{i-th} latent dimension 18 | } 19 | \description{ 20 | Compute the shape changes between two blocks of 2D or 3D shape coordiantes along the common axis of deformations defined by each dimension of the latent space 21 | } 22 | \note{ 23 | this give the same results as \code{plsCoVar}, however, using common shape vectors as suggested by Mitteroecker and Bookstein (2007) 24 | } 25 | \examples{ 26 | data(boneData) 27 | proc <- procSym(boneLM) 28 | pls <- pls2B(proc$orpdata[1:4,,],proc$orpdata[5:10,,]) 29 | commShape <- getPLSCommonShape(pls) 30 | ## get common shape for first latent dimension at +-2 sd of the scores 31 | pred <- plsCoVarCommonShape(pls,1,2) 32 | \dontrun{ 33 | deformGrid3d(pred[,,1],pred[,,2]) 34 | } 35 | } 36 | \references{ 37 | Mitteroecker P, Bookstein F. 2007. The conceptual and statistical relationship between modularity and morphological integration. Systematic Biology 56(5):818-836. 38 | } 39 | \seealso{ 40 | \code{\link{pls2B}, \link{getPLSfromScores}, \link{predictPLSfromScores}, \link{getPLSscores}, \link{predictPLSfromData},\link{svd}, \link{plsCoVar}, \link{getPLSCommonShape}} 41 | } 42 | -------------------------------------------------------------------------------- /R/read.lmdta.r: -------------------------------------------------------------------------------- 1 | #' read dta files 2 | #' 3 | #' reads .dta files created by the software Landmark 4 | #' http://graphics.idav.ucdavis.edu/research/EvoMorph 5 | #' 6 | #' 7 | #' @param file a dta file 8 | #' @param na specifies a value that indicates missing values 9 | #' @return 10 | #' \item{arr }{array containing landmarks dimnames will be Information of 11 | #' ID and landmark names specified in Landmark} 12 | #' \item{info }{Information extracted from the header of the dta file} 13 | #' \item{idnames }{character vector containing the names of the individuals 14 | #' as specified in the dta file} 15 | #' 16 | #' @export 17 | read.lmdta <- function(file="x", na=9999) { 18 | x <- file 19 | A <- readLines(x) 20 | em <- which(A=="") 21 | infoline <- grep("DIM=",A,ignore.case = TRUE) 22 | idlines <- infoline+min(which(A[-c(1:infoline)] != "")) 23 | endid <- idlines+min(which(A[-c(1:idlines)] == "")) 24 | idnames <- A[c((idlines):(endid-1))] 25 | info <- strsplit(A[infoline]," ")[[1]] 26 | n2 <- nchar(info[2])-1 27 | nspeci <- as.numeric(substr(info[2],1L,n2)) 28 | ndim <- as.numeric(substr(info[6],5,nchar(info[6]))) 29 | nlms <- as.numeric(info[3])/ndim 30 | eot <- endid 31 | B <- as.matrix(read.table(x,skip=eot),na.strings=as.numeric(info[5])) 32 | if (nrow(B) != nlms*nspeci) 33 | stop("number of landmarks in dataset not matching file header information") 34 | tt <- array(t(B),dim=c(ndim,nlms,nspeci)) 35 | arr <- array(NA,dim=c(nlms,ndim,nspeci)) 36 | for (i in 1:nspeci) 37 | arr[,,i] <- t(tt[,,i]) 38 | 39 | nas <- which(arr == na) 40 | if (length(nas) > 0) 41 | arr[nas] <- NA 42 | dimnames(arr)[[3]] <- as.list(idnames) 43 | return(list(arr=arr,info=info,idnames=idnames)) 44 | } 45 | -------------------------------------------------------------------------------- /R/qqmat.r: -------------------------------------------------------------------------------- 1 | #' Q-Q plot to assess normality of data 2 | #' 3 | #' qqmat plots Mahalanobisdistances of a given sample against those expected 4 | #' from a Gaussian distribution 5 | #' 6 | #' 7 | #' @param x sample data: matrix or vector 8 | #' @param output logical: if TRUE results are returned 9 | #' @param square plot in a square window - outliers might be cut off. 10 | #' @return if \code{output=TRUE}, the following values are returned 11 | #' \item{x }{distances from an expected Gaussian distribution} 12 | #' \item{y }{observed distances - sorted} 13 | #' \item{d }{observed distances - unsorted} 14 | #' @author Stefan Schlager 15 | #' @seealso \code{\link{qqplot}} 16 | #' 17 | #' @examples 18 | #' 19 | #' require(MASS) 20 | #' ### create normally distributed data 21 | #' data <- mvrnorm(100,mu=rep(0,5),Sigma = diag(5:1)) 22 | #' qqmat(data) 23 | #' 24 | #' ###create non normally distributed data 25 | #' data1 <- rchisq(100,df=3) 26 | #' qqmat(data1,square=FALSE) 27 | #' 28 | #' @export 29 | qqmat <- function(x,output=FALSE,square=FALSE) 30 | { 31 | x <- as.matrix(x) 32 | center <- colMeans(x) 33 | n <- nrow(x); p <- ncol(x); cov <- cov(x); 34 | d <- mahalanobis(x,center,cov) # distances 35 | x1 <- qchisq(ppoints(n),df=p) 36 | 37 | xlab <- "expected values for multivariate normal distribution" 38 | if (square) 39 | { 40 | ylim = c(range(x1)) 41 | out <- qqplot(x1,d,ylim =ylim ,main="QQ Plot Assessing Multivariate Normality",ylab="Mahalanobis D2",xlab=xlab) 42 | } 43 | else 44 | { 45 | out <- qqplot(x1,d ,main="QQ Plot Assessing Multivariate Normality",ylab="Mahalanobis D2",xlab=xlab) 46 | } 47 | out$d <- d 48 | abline(0,1) 49 | if(output) 50 | { 51 | return(out) 52 | } 53 | } 54 | -------------------------------------------------------------------------------- /man/getPLSCommonShape.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/pls2B.r 3 | \name{getPLSCommonShape} 4 | \alias{getPLSCommonShape} 5 | \title{Get the linear combinations associated with the common shape change in each latent dimension of a pls2B} 6 | \usage{ 7 | getPLSCommonShape(pls) 8 | } 9 | \arguments{ 10 | \item{pls}{object of class "pls2B"} 11 | } 12 | \value{ 13 | returns a list containing 14 | \item{shapevectors}{matrix with each containing the shapevectors (in column- major format) of common shape change associated with each latent dimension} 15 | \item{XscoresScaled}{Xscores scaled according to \code{shapevectors}} 16 | \item{YscoresScaled}{Yscores scaled according to \code{shapevectors}} 17 | \item{commoncenter}{Vector containing the common mean} 18 | \item{lmdim}{dimension of landmarks} 19 | } 20 | \description{ 21 | Get the linear combinations associated with the common shape change in each latent dimension of a pls2B 22 | } 23 | \examples{ 24 | data(boneData) 25 | proc <- procSym(boneLM) 26 | pls <- pls2B(proc$orpdata[1:4,,],proc$orpdata[5:10,,]) 27 | commShape <- getPLSCommonShape(pls) 28 | ## get common shape for first latent dimension at +-2 sd of the scores 29 | ## (you can do this much more convenient using \\code{\\link{plsCoVarCommonShape}} 30 | scores <- c(-2,2) * sd(c(commShape$XscoresScaled[,1],commShape$XscoresScaled[,2])) 31 | pred <- showPC(scores,commShape$shapevectors[,1],matrix(commShape$commoncenter,10,3)) 32 | \dontrun{ 33 | deformGrid3d(pred[,,1],pred[,,2]) 34 | } 35 | } 36 | \references{ 37 | Mitteroecker P, Bookstein F. 2007. The conceptual and statistical relationship between modularity and morphological integration. Systematic Biology 56(5):818-836. 38 | } 39 | \seealso{ 40 | \code{\link{plsCoVarCommonShape}} 41 | } 42 | -------------------------------------------------------------------------------- /man/regdist.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/regdist.raw.r 3 | \name{regdist} 4 | \alias{regdist} 5 | \title{correlation between shape space and tangent space} 6 | \usage{ 7 | regdist(dataarray, plot = TRUE, main = "", rho = "angle", 8 | dist.mat.out = FALSE) 9 | } 10 | \arguments{ 11 | \item{dataarray}{Input k x m x n real array, where k is the number of 12 | points, m is the number of dimensions, and n is the sample size.} 13 | 14 | \item{plot}{Logical: whether to plot the distances between observations.} 15 | 16 | \item{main}{character string: Title of the plot.} 17 | 18 | \item{rho}{chose how to calculate distances in shape space. Options: 19 | "riemdist"=Riemannian distance (function from the shapes package-takes along 20 | time to calculate), "angle"=calculates the angle between shape vectors, 21 | "sindist"=sinus of length of residual vector between shape vectors.} 22 | 23 | \item{dist.mat.out}{Logical: If TRUE, output will contain distance matrices.} 24 | } 25 | \value{ 26 | \item{cor }{correlation coefficient between distances in shape space and 27 | tangent space} 28 | \item{procSS }{Procrustes Sums of Squares (of full procrustes distance)} 29 | \item{tanSS }{Tangent Sums of Squares} 30 | \item{rhoSS }{Procrustes Sums of Squares (of angle)} 31 | \item{euc.dist }{distance matrix of euclidean distance in Tangent space} 32 | \item{proc.dist }{distance matrix of Procrustes distance in Shape space} 33 | } 34 | \description{ 35 | performs a partial Procrustes superimposition of landmark data and 36 | calculates the correlation between tangent and shape space. 37 | } 38 | \examples{ 39 | 40 | if (require(shapes)) { 41 | regdist(gorf.dat) 42 | } 43 | } 44 | \seealso{ 45 | \code{\link{regdist}} 46 | } 47 | \author{ 48 | Stefan Schlager 49 | } 50 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | 2 | Morpho [![Travis Build Status](https://travis-ci.org/zarquon42b/Morpho.png?branch=master)](https://travis-ci.org/zarquon42b/Morpho) [![License](http://img.shields.io/badge/license-GPL%20%28%3E=%202%29-brightgreen.svg?style=flat)](http://www.gnu.org/licenses/gpl-2.0.html) [![Downloads](http://cranlogs.r-pkg.org/badges/Morpho?color=brightgreen)](http://www.r-pkg.org/pkg/Morpho) 3 | ====== 4 | __Morpho__ provides a rich toolset for Geometric Morphometrics and mesh processing in R. This includes (among other stuff) mesh deformations based on reference points, permutation tests, detection of outliers, processing of sliding semi-landmarks, im- and export of a variety of triangular surface mesh files. 5 | 6 | 7 | #### Installation of the R-package Morpho from CRAN: #### 8 | 9 | Within R: 10 | 11 | install.packages("Morpho") 12 | 13 | 14 | #### Installation of the R-package Morpho (development snapshot) using *devtools*: #### 15 | 16 | ##### Install prerequisites ##### 17 | 18 | 1. Install *devtools* from within R (Ubuntu/Debian users will have to install *libcurl4-gnutls-dev* beforehand): 19 | 20 | install.packages("devtools") 21 | 22 | **Make sure to have the latest versions of Rcpp and RcppArmadillo installed!!** 23 | 24 | 25 | 2. Install build environment 26 | * **Windows:** Install latest version of *[Rtools](http://cran.r-project.org/bin/windows/Rtools)* 27 | During installation of *Rtools* make sure to install the *toolchain*, and to select *"Edit the system path"* (and confirming the installers suggestions). 28 | * **OSX:** Install *[XCODE](https://developer.apple.com/xcode/)* 29 | 30 | ##### Install Morpho ##### 31 | 32 | Run the following command in R: 33 | 34 | require(devtools) 35 | install_github("zarquon42b/Morpho", local=FALSE) 36 | 37 | 38 | -------------------------------------------------------------------------------- /man/exVar.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/exVar.r 3 | \name{exVar} 4 | \alias{exVar} 5 | \alias{exVar.lm} 6 | \alias{exVar.mvr} 7 | \title{calculate variance of a distribution stemming from prediction models} 8 | \usage{ 9 | exVar(model, ...) 10 | 11 | \method{exVar}{lm}(model, ...) 12 | 13 | \method{exVar}{mvr}(model, ncomp, val = FALSE, ...) 14 | } 15 | \arguments{ 16 | \item{model}{a model of classes "lm" or "mvr" (from the package "pls")} 17 | 18 | \item{\dots}{currently unused additional arguments.} 19 | 20 | \item{ncomp}{How many latent variables to use (only for mvr models)} 21 | 22 | \item{val}{use cross-vaildated predictions (only for mvr models)} 23 | } 24 | \value{ 25 | returns the quotient. 26 | } 27 | \description{ 28 | calculates a quotient of the overall varriance within a predicted 29 | distribution to that from the original one. This function calculates a naive extension of the univariate R^2-value by 30 | dividing the variance in the predicted dat by the variance of the original 31 | data. No additional adjustments are made!! 32 | } 33 | \note{ 34 | The result is only!! a rough estimate of the variance explained by a 35 | multivariate model. And the result can be misleading - especially when there 36 | are many predictor variables involved. If one is interested in the value 37 | each factor/covariate explains, we recommend a 50-50 MANOVA perfomed by the 38 | R-package "ffmanova", which reports this value factor-wise. 39 | } 40 | \examples{ 41 | 42 | lm1 <- lm(as.matrix(iris[,1:4]) ~ iris[,5]) 43 | exVar(lm1) 44 | } 45 | \references{ 46 | Langsrud O, Juergensen K, Ofstad R, Naes T. 2007. Analyzing 47 | Designed Experiments with Multiple Responses Journal of Applied Statistics 48 | 34:1275-1296. 49 | } 50 | \author{ 51 | Stefan Schlager 52 | } 53 | -------------------------------------------------------------------------------- /man/NNshapeReg.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/NNshapeReg.r 3 | \name{NNshapeReg} 4 | \alias{NNshapeReg} 5 | \title{Estimate the shape by averaging the shape of the nearest neighbours.} 6 | \usage{ 7 | NNshapeReg(x, y = NULL, n = 3, mahalanobis = FALSE, 8 | mc.cores = parallel::detectCores()) 9 | } 10 | \arguments{ 11 | \item{x}{an array or matrix (one row per specim) with data used for 12 | estimating weights.} 13 | 14 | \item{y}{an array or matrix (one row per specim) with landmark data on which 15 | the weighted averaging is applied for prediction. If NULL, x will be used 16 | for both tasks.} 17 | 18 | \item{n}{amount of nearest neighbours to consider} 19 | 20 | \item{mahalanobis}{logical: use mahalanobis distance} 21 | 22 | \item{mc.cores}{integer: amount of cores used for parallel processing.} 23 | } 24 | \value{ 25 | matrix or array of estimates. 26 | } 27 | \description{ 28 | Estimate the shape of one set of landmarks by averaging the shape of the 29 | nearest neighbours obtained by a second set of landmarks. Weights are 30 | calculated either form Mahalanobis or Procrustes distances. This can be 31 | useful for data with missing landmarks. 32 | } 33 | \details{ 34 | This function calculates weights from one set of shape data and then 35 | estimates the shape of another (or same) set of landmarks. CAUTION: 36 | landmark data has to be registered beforehand. 37 | } 38 | \examples{ 39 | 40 | if (require(shapes)) { 41 | proc <- procSym(gorf.dat) 42 | #use the closest 3 specimen based on the first 4 landmarks 43 | #to estimate the shape 44 | estim <- NNshapeReg(proc$rotated[1:4,,],proc$rotated,n=3,mc.cores=1) 45 | #compare estimation and true config 46 | plot(proc$rotated[,,1],asp=1) 47 | points(estim[,,1],col=2) 48 | } 49 | 50 | } 51 | \seealso{ 52 | \code{\link{proc.weight}}, \code{\link{fixLMtps}} 53 | } 54 | -------------------------------------------------------------------------------- /man/name2factor.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/name2.r 3 | \name{name2factor} 4 | \alias{name2factor} 5 | \alias{name2num} 6 | \title{extract data from array names} 7 | \usage{ 8 | name2factor(x, sep = "_", which, collapse = sep, as.factor = TRUE) 9 | 10 | name2num(x, sep = "_", which, collapse = sep, dif = TRUE) 11 | } 12 | \arguments{ 13 | \item{x}{data, can be a three-dimensional array, a matrix, a named list or a 14 | vector containing names to split} 15 | 16 | \item{sep}{character by which to split the strings} 17 | 18 | \item{which}{integer or vector of integers, if more entries are selected, 19 | they will be concatenated by the string specified with the option 20 | 'collapse'.} 21 | 22 | \item{collapse}{character by which to collapse data if two strings are to be 23 | concatenated} 24 | 25 | \item{as.factor}{logical: if TRUE, a factor vector will be returned, strings otherwise.} 26 | 27 | \item{dif}{logical: calculate difference if two fields containing numbers 28 | are selected.} 29 | } 30 | \value{ 31 | returns a vector containing factors or numbers 32 | } 33 | \description{ 34 | extract data from array names 35 | } 36 | \details{ 37 | extract data from array names and convert to factors or numbers 38 | 39 | If an array is used as input, the data info is expected to be in the 3rd 40 | dimension, for a matrix, rownames are used. 41 | } 42 | \examples{ 43 | 44 | 45 | data <- matrix(rnorm(200),100,2) 46 | id <- paste("id",1:100,sep="") 47 | pop <- c(rep("pop1",50),rep("pop2",50)) 48 | sex <- c(rep("male",50),rep("female",50)) 49 | age <- floor(rnorm(100,mean=50,sd=10)) 50 | rownames(data) <- paste(id,pop,sex,age,sep="_") 51 | infos <- data.frame(pop=name2factor(data,which=2)) 52 | infos$age <- name2num(data,which=4) 53 | infos$pop.sex <- name2factor(data,which=2:3) 54 | 55 | 56 | } 57 | \author{ 58 | Stefan Schlager 59 | } 60 | -------------------------------------------------------------------------------- /src/CVAdists.cpp: -------------------------------------------------------------------------------- 1 | #include "CVAdists.h" 2 | 3 | 4 | SEXP CVAdists(SEXP data_, SEXP groups_, SEXP rounds_, SEXP winv_) { 5 | try { 6 | mat armaData = as(data_); 7 | mat winvA = as(winv_); 8 | arma::ivec armaGroups = Rcpp::as(groups_); 9 | int rounds = as(rounds_); 10 | 11 | //ivec armaGroups(groups.begin(),groups.size(),false); 12 | int maxlev = armaGroups.max(); 13 | int alldist=0; 14 | for (int i=1; i < maxlev; ++i) 15 | alldist +=i; 16 | 17 | ivec permuvec = armaGroups; 18 | List outPlain(alldist); 19 | List outMaha(alldist); 20 | //setup output lists and fill with empty vectors 21 | for (int i=0; i < alldist; ++i) { 22 | NumericVector dist0(rounds+1); 23 | outPlain[i] =dist0; 24 | NumericVector dist1(rounds+1); 25 | outMaha[i] = dist1; 26 | } 27 | for (int i=0; i <= rounds; ++i) { 28 | int count = 0; 29 | if (i > 0) 30 | permuvec = shuffle(permuvec); 31 | for (int j0 = 1; j0 < maxlev; ++j0) { 32 | mat tmp1 = armaData.rows(arma::find(permuvec == j0 )); 33 | mat mean1 = mean(tmp1,0); 34 | for(int j1 =j0+1; j1 <= maxlev; ++j1) { 35 | mat tmp2 = armaData.rows(arma::find(permuvec == j1 )); 36 | mat mean2 = mean(tmp2,0); 37 | mat diff = mean1-mean2; 38 | double tmpdist = norm(diff,2); 39 | NumericVector dists = outPlain[count]; 40 | dists[i] = tmpdist; 41 | outPlain[count] = dists; 42 | // mahalanobis distances 43 | mat tmpdist0 = sqrt(diff*winvA*diff.t()); 44 | dists = outMaha[count]; 45 | dists[i] = tmpdist0(0,0); 46 | outMaha[count] = dists; 47 | count +=1; 48 | } 49 | } 50 | } 51 | return List::create(Named("Maha")=outMaha, 52 | Named("Plain") = outPlain) 53 | ; 54 | } catch (std::exception& e) { 55 | ::Rf_error( e.what()); 56 | } catch (...) { 57 | ::Rf_error("unknown exception"); 58 | } 59 | } 60 | -------------------------------------------------------------------------------- /man/rotonmat.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/rotonmat.r 3 | \name{rotonmat} 4 | \alias{rotonmat} 5 | \title{rotate matrix of landmarks} 6 | \usage{ 7 | rotonmat(X, refmat, tarmat, scale = TRUE, reflection = FALSE, 8 | weights = NULL, centerweight = FALSE, getTrafo = FALSE) 9 | } 10 | \arguments{ 11 | \item{X}{Matrix to be rotated} 12 | 13 | \item{refmat}{reference matrix used to estimate rotation parameters} 14 | 15 | \item{tarmat}{target matrix used to estimate rotation parameters} 16 | 17 | \item{scale}{logical: requests scaling to minimize sums of squared distances} 18 | 19 | \item{reflection}{logical: if TRUE, reflections are allowed.} 20 | 21 | \item{weights}{vector of length k, containing weights for each landmark.} 22 | 23 | \item{centerweight}{logical: if weights are defined and centerweigths=TRUE, 24 | the matrix will be centered according to these weights instead of the 25 | barycenter.} 26 | 27 | \item{getTrafo}{logical: if TRUE, a 4x4 transformation matrix will also be returned.} 28 | } 29 | \value{ 30 | if \code{getTrafo=FALSE} the transformed X will be returned, 31 | else alist containing: 32 | \item{Xrot}{the transformed matrix X} 33 | \item{trafo}{a 4x4 transformation matrix} 34 | } 35 | \description{ 36 | rotate matrix of landmarks by using a rotation determined by two matrices. 37 | } 38 | \details{ 39 | A matrix is rotated by rotation parameters determined by two different 40 | matrices. This is usefull, if the rotation parameters are to be estimated by 41 | a subset of landmark coordinates. 42 | } 43 | \examples{ 44 | 45 | 46 | data(nose) 47 | shortnose.rot <- 48 | rotonmat(shortnose.lm,shortnose.lm[1:9,],longnose.lm[1:9,]) 49 | 50 | ##view result 51 | \dontrun{ 52 | deformGrid3d(shortnose.rot,shortnose.lm,ngrid=0) 53 | } 54 | } 55 | \seealso{ 56 | \code{\link{rotonto}},\code{\link{rotmesh.onto}} 57 | } 58 | \author{ 59 | Stefan Schlager 60 | } 61 | -------------------------------------------------------------------------------- /man/cutSpace.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/cutSpace.r 3 | \name{cutSpace} 4 | \alias{cutSpace} 5 | \title{separate a 3D-pointcloud by a hyperplane} 6 | \usage{ 7 | cutSpace(pointcloud, v1, v2 = NULL, v3 = NULL, normal = NULL, 8 | upper = TRUE) 9 | } 10 | \arguments{ 11 | \item{pointcloud}{numeric n x 3 matrix} 12 | 13 | \item{v1}{numeric vector of length=3 specifying a point on the separating plane} 14 | 15 | \item{v2}{numeric vector of length=3 specifying a point on the separating plane} 16 | 17 | \item{v3}{numeric vector of length=3 specifying a point on the separating plane} 18 | 19 | \item{normal}{plane normal (overrides specification by v2 and v3)} 20 | 21 | \item{upper}{logical specify whether the points above or below the plane are to be reported as TRUE.} 22 | } 23 | \value{ 24 | logical vector of length n. Reporting for each point if it is above or below the hyperplane 25 | } 26 | \description{ 27 | separate a 3D-pointcloud by a hyperplane 28 | } 29 | \details{ 30 | As above and below are specified by the normal calculated from \eqn{(v2-v1) \times (v3-v1)}{(v2-v1) x (v3-v1)}, where \eqn{\times}{x} denotes the vector crossproduct. This means the normal points "upward" when viewed from the positon where v1, v2 and v3 are arranged counter-clockwise. Thus, which side is "up" depends on the ordering of v1, v2 and v3. 31 | } 32 | \examples{ 33 | data(nose) 34 | v1 <- shortnose.lm[1,] 35 | v2 <- shortnose.lm[2,] 36 | v3 <- shortnose.lm[3,] 37 | pointcloud <- vert2points(shortnose.mesh) 38 | upper <- cutSpace(pointcloud, v1, v2, v3) 39 | \dontrun{ 40 | require(rgl) 41 | normal <- crossProduct(v2-v1,v3-v1) 42 | zeroPro <- points2plane(rep(0,3),v1,normal) 43 | ## get sign of normal displacement from zero 44 | sig <- sign(crossprod(-zeroPro,normal)) 45 | d <- sig*norm(zeroPro,"2") 46 | planes3d(normal[1],normal[2],normal[3],d=d) 47 | points3d(pointcloud[upper,]) 48 | } 49 | } 50 | -------------------------------------------------------------------------------- /man/createAtlas.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/Atlas.r 3 | \name{createAtlas} 4 | \alias{createAtlas} 5 | \title{Create an atlas needed in placePatch} 6 | \usage{ 7 | createAtlas(mesh, landmarks, patch, corrCurves = NULL, patchCurves = NULL, 8 | keep.fix = NULL) 9 | } 10 | \arguments{ 11 | \item{mesh}{triangular mesh representing the atlas' surface} 12 | 13 | \item{landmarks}{matrix containing landmarks defined on the atlas, as well 14 | as on each specimen in the corresponding sample.} 15 | 16 | \item{patch}{matrix containing semi-landmarks to be projected onto each 17 | specimen in the corresponding sample.} 18 | 19 | \item{corrCurves}{a vector or a list containing vectors specifiyng the rowindices of 20 | \code{landmarks} to be curves that are defined on the atlas AND each specimen. 21 | e.g. if landmarks 2:4 and 5:10 are two distinct curves, one would specifiy \code{corrCurves = list(c(2:4), c(5:10))}.} 22 | 23 | \item{patchCurves}{a vector or a list containing vectors specifiyng the 24 | rowindices of \code{landmarks} to be curves that are defined ONLY on the 25 | atlas. E.g. if coordinates 5:10 and 20:40 on the \code{patch} are two 26 | distinct curves, one would specifiy \code{patchCurves = list(c(5:10),c(20:40))}.} 27 | 28 | \item{keep.fix}{in case corrCurves are set, specify explicitly which landmarks are not allowed to slide during projection (with \code{placePatch})} 29 | } 30 | \value{ 31 | Returns a list of class "atlas". Its content is corresponding to 32 | argument names. 33 | } 34 | \description{ 35 | Create an atlas needed in placePatch 36 | } 37 | \note{ 38 | This is a helper function of \code{\link{placePatch}}. 39 | } 40 | \examples{ 41 | 42 | data(nose) 43 | atlas <- createAtlas(shortnose.mesh, landmarks = 44 | shortnose.lm[c(1:5,20:21),], patch=shortnose.lm[-c(1:5,20:21),]) 45 | 46 | } 47 | \seealso{ 48 | \code{\link{placePatch}, \link{plotAtlas}} 49 | } 50 | -------------------------------------------------------------------------------- /man/plotAtlas.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/Atlas.r 3 | \name{plotAtlas} 4 | \alias{plotAtlas} 5 | \title{visualize an atlas defined by createAtlas} 6 | \usage{ 7 | plotAtlas(atlas, pt.size = NULL, alpha = 1, render = c("w", "s"), 8 | point = c("s", "p"), meshcol = "white", add = TRUE, legend = TRUE, 9 | cols = 2:5) 10 | } 11 | \arguments{ 12 | \item{atlas}{object of class atlas created by \code{\link{createAtlas}}.} 13 | 14 | \item{pt.size}{size of plotted points/spheres. If \code{point="s"}. 15 | \code{pt.size} defines the radius of the spheres. If \code{point="p"} it 16 | sets the variable \code{size} used in \code{point3d}.} 17 | 18 | \item{alpha}{value between 0 and 1. Sets transparency of mesh 1=opaque 0= 19 | fully transparent.} 20 | 21 | \item{render}{if \code{render="w"}, a wireframe will be drawn, if 22 | \code{render="s"}, the mesh will be shaded.} 23 | 24 | \item{point}{how to render landmarks. "s"=spheres, "p"=points.} 25 | 26 | \item{meshcol}{color to render the atlas mesh} 27 | 28 | \item{add}{logical: if TRUE, a new rgl window is opened.} 29 | 30 | \item{legend}{logical: request plot of legend specifying landmark coloring.} 31 | 32 | \item{cols}{vector containing colors for each coordinate type cols[1]=landmarks, cols[2]=patch, cols[3]=corrCurves, cols[4]=patchCurves.} 33 | } 34 | \value{ 35 | returns invisible vector containing \code{rgl.id} of rendered 36 | objects. 37 | } 38 | \description{ 39 | visualize an atlas defined by createAtlas 40 | } 41 | \details{ 42 | If \code{legend=TRUE}, a plot with a legend will open where coloring of the 43 | 3D-spheres is specified. 44 | } 45 | \examples{ 46 | 47 | data(nose) 48 | atlas <- createAtlas(shortnose.mesh, landmarks = 49 | shortnose.lm[c(1:5,20:21),], patch=shortnose.lm[-c(1:5,20:21),]) 50 | \dontrun{ 51 | plotAtlas(atlas) 52 | } 53 | } 54 | \seealso{ 55 | \code{\link{placePatch}, \link{createAtlas}} 56 | } 57 | -------------------------------------------------------------------------------- /man/computeTransform.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/ComputeTransform.r 3 | \name{computeTransform} 4 | \alias{computeTransform} 5 | \title{calculate an affine transformation matrix} 6 | \usage{ 7 | computeTransform(x, y, type = c("rigid", "similarity", "affine", "tps"), 8 | reflection = FALSE, lambda = 1e-08, weights = NULL, 9 | centerweight = FALSE, threads = 1) 10 | } 11 | \arguments{ 12 | \item{x}{fix landmarks. Can be a k x m matrix or mesh3d.} 13 | 14 | \item{y}{moving landmarks. Can be a k x m matrix or mesh3d.} 15 | 16 | \item{type}{set type of affine transformation: options are "rigid", "similarity" (rigid + scale) and "affine",} 17 | 18 | \item{reflection}{logical: if TRUE "rigid" and "similarity" allow reflections.} 19 | 20 | \item{lambda}{numeric: regularisation parameter of the TPS.} 21 | 22 | \item{weights}{vector of length k, containing weights for each landmark (only used in type="rigid" or "similarity").} 23 | 24 | \item{centerweight}{logical or vector of weights: if weights are defined and 25 | centerweigths=TRUE, the matrix will be centered according to these weights instead of the 26 | barycenter. If centerweight is a vector of length \code{nrow(x)}, the barycenter will be weighted accordingly.} 27 | 28 | \item{threads}{number of threads to use in TPS interpolation.} 29 | } 30 | \value{ 31 | returns a 4x4 (3x3 in 2D case) transformation matrix or an object of class "tpsCoeff" in case of type="tps". 32 | } 33 | \description{ 34 | calculate an affine transformation matrix 35 | } 36 | \details{ 37 | \code{x} and \code{y} can also be a pair of meshes with corresponding vertices. 38 | } 39 | \note{ 40 | all lines containing NA, or NaN are ignored in computing the transformation. 41 | } 42 | \examples{ 43 | data(boneData) 44 | trafo <- computeTransform(boneLM[,,1],boneLM[,,2]) 45 | transLM <- applyTransform(boneLM[,,2],trafo) 46 | } 47 | \seealso{ 48 | \code{\link{rotonto}, link{rotmesh.onto}, \link{tps3d}} 49 | } 50 | -------------------------------------------------------------------------------- /R/ignoreNA.r: -------------------------------------------------------------------------------- 1 | # find NAs to ignore missing data and recompute curves and outlines 2 | ignoreNA <- function(datamatrix,outlines=NULL,SMvector=NULL,surp=NULL,pairedLM=0) { 3 | 4 | k <- nrow(datamatrix) 5 | ignore <- which(apply(datamatrix,1,function(x) x <- as.logical(sum(is.na(x))))) 6 | li <- length(ignore) 7 | lm.old <- c(1:k)[-ignore] 8 | mat.ptr <- matrix(c(1:(k-li),lm.old),k-li,2) 9 | ptr <- function(xo) ### define pointer function for indexing 10 | { 11 | if (length(which(ignore %in% xo))!= 0) 12 | xo <- xo[-which(xo %in% ignore)] 13 | for (i in 1:(k-li)) 14 | xo[which(xo==mat.ptr[i,2])] <- mat.ptr[i,1] 15 | return(xo) 16 | } 17 | 18 | if (!is.null(outlines)) ### update outline indices 19 | outlines <- lapply(outlines,ptr) 20 | if (!is.null(surp)) ### update surface indices 21 | surp <- ptr(surp) 22 | 23 | if (!is.null(SMvector)) ### of fixed/sliding definition 24 | SMvector <- ptr(SMvector) 25 | 26 | if (pairedLM[1]!=0){ ### update paired landmarks indices 27 | count <- 0 28 | del <- NULL 29 | for (i in 1:dim(pairedLM)[1]) { 30 | if (length(which(ignore %in% pairedLM[i,]))!=0) { 31 | count <- count+1 32 | del[count] <- i 33 | } 34 | } 35 | pairedLM <- pairedLM[-del,] 36 | if (is.vector(pairedLM)) 37 | pairedLM <- t(as.matrix(pairedLM)) 38 | 39 | if (dim(pairedLM)[1]==0) { 40 | pairedLM <- 0 41 | } else { 42 | pairedLM <- apply(pairedLM,2,ptr) 43 | if (is.vector(pairedLM)) 44 | pairedLM <- t(as.matrix(pairedLM)) 45 | } 46 | } 47 | datamatrix <- datamatrix[-ignore,] 48 | out <- list(datamatrix=datamatrix,ignore=ignore,outlines=outlines,SMvector=SMvector,surp=surp,pairedLM=pairedLM) 49 | return(out) 50 | 51 | } 52 | 53 | 54 | -------------------------------------------------------------------------------- /man/pcaplot3d.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/pcaplot3d.r 3 | \name{pcaplot3d} 4 | \alias{pcaplot3d} 5 | \alias{pcaplot3d.symproc} 6 | \alias{pcaplot3d.nosymproc} 7 | \title{visualization of shape variation} 8 | \usage{ 9 | pcaplot3d(x, ...) 10 | 11 | \method{pcaplot3d}{symproc}(x, pcshow = c(1, 2, 3), mag = 3, color = 4, 12 | lwd = 1, sym = TRUE, legend = TRUE, type = c("spheres", "points"), 13 | ...) 14 | 15 | \method{pcaplot3d}{nosymproc}(x, pcshow = c(1, 2, 3), mag = 3, color = 4, 16 | lwd = 1, legend = TRUE, type = c("spheres", "points"), ...) 17 | } 18 | \arguments{ 19 | \item{x}{a object derived from the function procSym calculated on 3D 20 | coordinates.} 21 | 22 | \item{\dots}{Additional parameters which will be passed to the methods.} 23 | 24 | \item{pcshow}{a vector containing the PCscores to be visualized.} 25 | 26 | \item{mag}{a vector or an integer containing which standard deviation of 27 | which PC has to be visualized.} 28 | 29 | \item{color}{color of the 3d points/spheres.} 30 | 31 | \item{lwd}{width of the lines representing the shape change.} 32 | 33 | \item{sym}{logical: if TRUE the symmetric component of shape is displayed. 34 | Otherwise the asymmetric one.} 35 | 36 | \item{legend}{logical: if TRUE a legend explaining the color coding of the PCs is plotted.} 37 | 38 | \item{type}{character: for \code{type="spheres"}, the landmarks will be rendered using rgl's \code{spheres3d} function and for \code{type="points"} by \code{points3d} respectivly.} 39 | } 40 | \value{ 41 | returns an invisible array containing the shapes associated with the Principal components selected. 42 | } 43 | \description{ 44 | visualization of shape change 45 | } 46 | \details{ 47 | visualization of the shape changes explained by Principal components 48 | } 49 | \examples{ 50 | 51 | \dontrun{ 52 | data(boneData) 53 | proc <- procSym(boneLM) 54 | pcaplot3d(proc,pcshow=1:3,mag=-3)#only one PC available 55 | } 56 | } 57 | \seealso{ 58 | \code{\link{procSym}} 59 | } 60 | -------------------------------------------------------------------------------- /man/rotmesh.onto.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/rotmesh.onto.r 3 | \name{rotmesh.onto} 4 | \alias{rotmesh.onto} 5 | \title{rotate ,scale and translate a mesh based on landmark information.} 6 | \usage{ 7 | rotmesh.onto(mesh, refmat, tarmat, adnormals = FALSE, scale = FALSE, 8 | reflection = FALSE, ...) 9 | } 10 | \arguments{ 11 | \item{mesh}{object of class mesh3d.} 12 | 13 | \item{refmat}{k x m matrix with landmarks on the mesh} 14 | 15 | \item{tarmat}{k x m matrix as target configuration} 16 | 17 | \item{adnormals}{logical - if TRUE, vertex normals will be recomputed after 18 | rotation. If \code{mesh} has normals and adnormals=FALSE, the existing 19 | normals are rotated by the same rotation matrix as the mesh's vertices.} 20 | 21 | \item{scale}{logical: if TRUE the mesh will be scaled according to the size 22 | of the target.} 23 | 24 | \item{reflection}{logical: allow reflection.} 25 | 26 | \item{...}{additional parameters passed on to \code{\link{rotonto}}.} 27 | } 28 | \value{ 29 | \item{mesh }{rotated mesh} 30 | \item{yrot }{rotated refmat} 31 | \item{trafo }{4x4 transformation matrix} 32 | } 33 | \description{ 34 | rotates and reflects a mesh onto by calculating the transformation from two 35 | sets of referenced landmarks. 36 | } 37 | \examples{ 38 | 39 | require(rgl) 40 | data(boneData) 41 | ## rotate, translate and scale the mesh belonging to the first specimen 42 | ## onto the landmark configuration of the 10th specimen 43 | rotmesh <- rotmesh.onto(skull_0144_ch_fe.mesh,boneLM[,,1], 44 | boneLM[,,10], scale=TRUE) 45 | \dontrun{ 46 | ## render rotated mesh and landmarks 47 | shade3d(rotmesh$mesh, col=2, specular=1) 48 | spheres3d(boneLM[,,1]) 49 | ## render original mesh 50 | shade3d(skull_0144_ch_fe.mesh, col=3, specular=1) 51 | spheres3d(boneLM[,,10]) 52 | } 53 | 54 | } 55 | \seealso{ 56 | \code{\link{file2mesh}},\code{\link{tps3d}} 57 | ,\code{\link{rotonto}},\code{\link{mesh2ply}} 58 | } 59 | \author{ 60 | Stefan Schlager 61 | } 62 | -------------------------------------------------------------------------------- /R/read.mpp.r: -------------------------------------------------------------------------------- 1 | #' Read saved pick-points from meshlab 2 | #' 3 | #' imports pick points selected with meshlab 4 | #' 5 | #' 6 | #' @param file file to import 7 | #' @param info logical: if TRUE, addtional infos are returned 8 | #' @return if \code{info=FALSE}: 9 | #' 10 | #' a matrix containing picked-points coordinates (only those tagged as active). 11 | #' 12 | #' if \code{info=TRUE}: a list containing 13 | #' \item{data }{matrix containing coordinates - including points tagged as inactive} 14 | #' \item{info }{additional info contained in file.} 15 | #' @author Stefan Schlager 16 | #' @seealso \code{\link{read.pts}} 17 | #' 18 | #' @export 19 | read.mpp <- function(file, info=FALSE) { 20 | raw <- readLines(file) 21 | points <- grep("]","",tmppoints)) 40 | datamat <- rbind(datamat,tmppoints) 41 | tmpinfo <- data[[i]][getinds[[i]]$infoind] 42 | tmpinfo <- gsub("[a-z,\\,\",\\=,\\/,\\>]","",tmpinfo) 43 | infomat <- rbind(infomat,tmpinfo) 44 | } 45 | rownames(infomat) <- NULL 46 | colnames(infomat) <- c("name","active") 47 | infomat <- as.data.frame(infomat) 48 | rownames(datamat) <- infomat$name 49 | 50 | if (info) 51 | return(list(data=datamat,info=infomat)) 52 | else { 53 | datamat <- datamat[which(infomat$active == 1),] 54 | return(datamat) 55 | } 56 | } 57 | 58 | 59 | -------------------------------------------------------------------------------- /man/deformGrid2d.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/deformGrid2d.r 3 | \name{deformGrid2d} 4 | \alias{deformGrid2d} 5 | \title{visualise differences between two superimposed sets of 2D landmarks} 6 | \usage{ 7 | deformGrid2d(matrix, tarmatrix, ngrid = 0, lwd = 1, show = c(1:2), 8 | lines = TRUE, lcol = 1, col1 = 2, col2 = 3, pcaxis = FALSE, 9 | add = FALSE, wireframe = NULL, margin = 0.2, ...) 10 | } 11 | \arguments{ 12 | \item{matrix}{reference matrix containing 2D landmark coordinates or mesh of class "mesh3d"} 13 | 14 | \item{tarmatrix}{target matrix containing 2D landmark coordinates or mesh of class "mesh3d"} 15 | 16 | \item{ngrid}{number of grid lines to be plotted; ngrid=0 suppresses grid 17 | creation.} 18 | 19 | \item{lwd}{width of lines connecting landmarks.} 20 | 21 | \item{show}{integer (vector): if c(1:2) both configs will be plotted, show = 1 only plots the reference and show = 2 the target. 22 | plotted. Options are combinations of 1,2 and 3.} 23 | 24 | \item{lines}{logical: if TRUE, lines between landmarks will be plotted.} 25 | 26 | \item{lcol}{color of lines} 27 | 28 | \item{col1}{color of "matrix"} 29 | 30 | \item{col2}{color of "tarmat"} 31 | 32 | \item{pcaxis}{logical: align grid by shape's principal axes.} 33 | 34 | \item{add}{logical: if TRUE, output will be drawn on existing plot.} 35 | 36 | \item{wireframe}{list/vector containing row indices to be plotted as wireframe (see \code{\link{lineplot}}.)} 37 | 38 | \item{margin}{margin around the bounding box to draw the grid} 39 | 40 | \item{...}{additional parameters passed to plot} 41 | } 42 | \description{ 43 | visualise differences between two superimposed sets of 2D landmarks by 44 | deforming a square grid based on a thin-plate spline interpolation 45 | } 46 | \examples{ 47 | if (require(shapes)) { 48 | proc <- procSym(gorf.dat) 49 | deformGrid2d(proc$mshape,proc$rotated[,,1],ngrid=5,pch=19) 50 | } 51 | 52 | } 53 | \seealso{ 54 | \code{\link{tps3d}} 55 | } 56 | \author{ 57 | Stefan Schlager 58 | } 59 | -------------------------------------------------------------------------------- /man/points2plane.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/points2plane.r 3 | \name{points2plane} 4 | \alias{points2plane} 5 | \title{projects a 3D coordinate orthogonally onto a plane} 6 | \usage{ 7 | points2plane(x, v1, normal = NULL, v2 = NULL, v3 = NULL) 8 | } 9 | \arguments{ 10 | \item{x}{3D-vector or a k x 3 matrix with 3D vectors stored in rows} 11 | 12 | \item{v1}{point on plane} 13 | 14 | \item{normal}{plane normal (overrides specification by v2 and v3)} 15 | 16 | \item{v2}{if pNorm=NULL, the plane will be defined by three points \code{v1, v2, v3}} 17 | 18 | \item{v3}{if pNorm=NULL, the plane will be defined by three points \code{v1, v2, v3}} 19 | } 20 | \value{ 21 | projected point 22 | } 23 | \description{ 24 | projects a 3D coordinate orthogonally onto a plane 25 | } 26 | \examples{ 27 | data(boneData) 28 | ##project rhinion onto plane spanned by Nasion and both Nariales 29 | rpro <- points2plane(boneLM[10,,1],v1=boneLM[9,,1],v2=boneLM[3,,1],v3=boneLM[4,,1]) 30 | 31 | \dontrun{ 32 | require(rgl) 33 | #visualize 34 | wire3d(skull_0144_ch_fe.mesh,col="white") 35 | ##get plane normal 36 | normal <- crossProduct(boneLM[3,,1]-boneLM[9,,1],boneLM[4,,1]-boneLM[9,,1]) 37 | #' ## get plane offset 38 | d <- norm(points2plane(c(0,0,0),v1=boneLM[9,,1],normal=normal),"2") 39 | spheres3d(boneLM[,,1],radius=0.5) 40 | spheres3d(boneLM[c(3,4,9),,1],radius=0.6,col=3) 41 | ##original position of Rhinion 42 | spheres3d(boneLM[10,,1],radius=0.6,col=2) 43 | ##projected onto plane 44 | spheres3d(rpro,radius=0.9,col=6) 45 | lines3d(rbind(rpro,boneLM[10,,1]),lwd=3) 46 | ##plot plane 47 | planes3d(normal[1],normal[2],normal[3],d=d,col=2,alpha=0.5) 48 | 49 | ##now we project all points onto that plane: 50 | spheres3d(points2plane(boneLM[,,1],v1=boneLM[9,,1],v2=boneLM[3,,1],v3=boneLM[4,,1]),col=3) 51 | 52 | ## and finally project the vertices of the mesh onto the plane 53 | meshpro <- points2plane(vert2points(skull_0144_ch_fe.mesh),v1=boneLM[9,,1],normal=normal) 54 | points3d(meshpro,col=2) 55 | } 56 | } 57 | -------------------------------------------------------------------------------- /R/rotonmat.r: -------------------------------------------------------------------------------- 1 | #' rotate matrix of landmarks 2 | #' 3 | #' rotate matrix of landmarks by using a rotation determined by two matrices. 4 | #' 5 | #' A matrix is rotated by rotation parameters determined by two different 6 | #' matrices. This is usefull, if the rotation parameters are to be estimated by 7 | #' a subset of landmark coordinates. 8 | #' 9 | #' @param X Matrix to be rotated 10 | #' @param refmat reference matrix used to estimate rotation parameters 11 | #' @param tarmat target matrix used to estimate rotation parameters 12 | #' @param scale logical: requests scaling to minimize sums of squared distances 13 | #' @param reflection logical: if TRUE, reflections are allowed. 14 | #' @param weights vector of length k, containing weights for each landmark. 15 | #' @param centerweight logical: if weights are defined and centerweigths=TRUE, 16 | #' the matrix will be centered according to these weights instead of the 17 | #' barycenter. 18 | #' @param getTrafo logical: if TRUE, a 4x4 transformation matrix will also be returned. 19 | #' @return if \code{getTrafo=FALSE} the transformed X will be returned, 20 | #' else alist containing: 21 | #' \item{Xrot}{the transformed matrix X} 22 | #' \item{trafo}{a 4x4 transformation matrix} 23 | #' @author Stefan Schlager 24 | #' @seealso \code{\link{rotonto}},\code{\link{rotmesh.onto}} 25 | #' 26 | #' @examples 27 | #' 28 | #' 29 | #' data(nose) 30 | #' shortnose.rot <- 31 | #' rotonmat(shortnose.lm,shortnose.lm[1:9,],longnose.lm[1:9,]) 32 | #' 33 | #' ##view result 34 | #' \dontrun{ 35 | #' deformGrid3d(shortnose.rot,shortnose.lm,ngrid=0) 36 | #' } 37 | #' @export 38 | rotonmat <- function(X,refmat,tarmat,scale=TRUE,reflection=FALSE, weights=NULL, centerweight=FALSE,getTrafo=FALSE) { 39 | ro <- rotonto(tarmat,refmat,scale=scale,signref=F,reflection=reflection, weights=weights, centerweight=centerweight) 40 | hmat <- getTrafo4x4(ro) 41 | Xrot <- homg2mat(hmat%*%mat2homg(X)) 42 | if (!getTrafo) 43 | return(Xrot) 44 | else 45 | return(list(Xrot=Xrot,trafo=hmat)) 46 | } 47 | -------------------------------------------------------------------------------- /man/mesh2ply.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/mesh2obj.r, R/mesh2ply.r 3 | \name{mesh2obj} 4 | \alias{mesh2obj} 5 | \alias{mesh2ply} 6 | \title{export mesh objects to disk} 7 | \usage{ 8 | mesh2obj(x, filename = dataname) 9 | 10 | mesh2ply(x, filename = dataname, col = NULL, writeNormals = FALSE) 11 | } 12 | \arguments{ 13 | \item{x}{object of class \code{mesh3d} - see rgl documentation for further 14 | details or a matrix containing vertices, this can either be a \code{k x 3} 15 | or a \code{3 x k} matrix, with rows or columns containing vertex 16 | coordinates.} 17 | 18 | \item{filename}{character: Path/name of the requested output - extension 19 | will be added atuomatically. If not specified, the file will be named as the 20 | exported object.} 21 | 22 | \item{col}{Writes color information to ply file. Can be either a single 23 | color value or a vector containing a color value for each vertex of the 24 | mesh.} 25 | 26 | \item{writeNormals}{logical: if TRUE, existing normals of a mesh are written 27 | to file - can slow things down for very large meshes.} 28 | } 29 | \description{ 30 | export mesh objects to disk. 31 | } 32 | \details{ 33 | export an object of class \code{mesh3d} or a set of coordinates to a common 34 | mesh file. 35 | } 36 | \note{ 37 | meshes containing quadrangular faces will be converted to triangular meshes by splitting the faces. 38 | } 39 | \examples{ 40 | 41 | require(rgl) 42 | 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, 43 | 1.8,-1.8,1.0,-1.8,-1.8,1.8,1.0,1.8, 44 | -1.8,1.8,1.0,-1.8,1.8,1.8,1.0,1.8,1.8,1.8,1.0) 45 | 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) 46 | vb <- matrix(vb,4,8) ##create vertex matrix 47 | it <- matrix(it,3,12) ## create face matrix 48 | cube<-list(vb=vb,it=it) 49 | class(cube) <- "mesh3d" 50 | \dontrun{ 51 | shade3d(cube,col=3) ## view the green cube 52 | } 53 | mesh2ply(cube,filename="cube") # write cube to a file called cube.ply 54 | } 55 | \seealso{ 56 | \code{\link{ply2mesh}, \link{quad2trimesh} } 57 | } 58 | \author{ 59 | Stefan Schlager 60 | } 61 | -------------------------------------------------------------------------------- /man/pcAlign.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/pcAlign.r 3 | \name{pcAlign} 4 | \alias{pcAlign} 5 | \alias{pcAlign.matrix} 6 | \alias{pcAlign.mesh3d} 7 | \title{align two 3D-pointclouds/meshes by their principal axes} 8 | \usage{ 9 | pcAlign(x, y, optim = TRUE, subsample = NULL, iterations = 10, 10 | mc.cores = 2) 11 | 12 | \method{pcAlign}{matrix}(x, y, optim = TRUE, subsample = NULL, 13 | iterations = 10, mc.cores = 2) 14 | 15 | \method{pcAlign}{mesh3d}(x, y, optim = TRUE, subsample = NULL, 16 | iterations = 10, mc.cores = 2) 17 | } 18 | \arguments{ 19 | \item{x}{matrix or mesh3d} 20 | 21 | \item{y}{matrix or mesh3d, if missing, x will be centered by its centroid and aligned by its princial axis.} 22 | 23 | \item{optim}{logical if TRUE, the RMSE between reference and target will be minimized testing all possible axes alignments and (if iterations > 0) followed by a rigid ICP procedure.} 24 | 25 | \item{subsample}{integer: use subsampled points to decrease computation time of optimization.} 26 | 27 | \item{iterations}{integer: number of iterations for optimization (the higher the more accurate but also more time consuming).} 28 | 29 | \item{mc.cores}{use parallel processing to find best alignment to original shape.} 30 | } 31 | \value{ 32 | rotated and translated version of x to the center and principal axes of y. 33 | } 34 | \description{ 35 | align two 3D-pointclouds/meshes by their principal axes 36 | } 37 | \details{ 38 | \code{x} and \code{y} will first be centered and aligned by their PC-axes. If \code{optim=TRUE},all possible 8 ordinations of PC-axes will be tested and the one with the smallest RMSE between the transformed version of \code{x} and the closest points on \code{y} will be used. Then the rotated version of \code{x} is translated to the original center of mass of \code{y}. 39 | } 40 | \examples{ 41 | data(boneData) 42 | blm1 <- pcAlign(boneLM[,,1],boneLM[,,2]) 43 | \dontrun{ 44 | require(rgl) 45 | spheres3d(boneLM[,,1])#original position 46 | spheres3d(blm1,col=2)#aligned configuration 47 | spheres3d(boneLM[,,2],col=3)#target 48 | } 49 | } 50 | -------------------------------------------------------------------------------- /man/equidistantCurve.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/equidistantCurve.r 3 | \name{equidistantCurve} 4 | \alias{equidistantCurve} 5 | \title{make a curve equidistant (optionally up/downsampling)} 6 | \usage{ 7 | equidistantCurve(x, n = NULL, open = TRUE, subsample = 0, increment = 2, 8 | smoothit = 0, mesh = NULL, iterations = 1) 9 | } 10 | \arguments{ 11 | \item{x}{k x m matrix containing the 2D or 3D coordinates} 12 | 13 | \item{n}{integer: number of coordinates to sample. If NULL, the existing curve will be made equidistant.} 14 | 15 | \item{open}{logical: specifies whether the curve is open or closed.} 16 | 17 | \item{subsample}{integer: number of subsamples to draw from curve for interpolation. For curves with < 1000 points, no subsampling is required.} 18 | 19 | \item{increment}{integer: if > 1, the curve is estimated iteratively by incrementing the original points by this factor. The closer this value to 1, the smoother the line but possibly farther away from the control points.} 20 | 21 | \item{smoothit}{integer: smoothing iterations after each step} 22 | 23 | \item{mesh}{specify mesh to project point to} 24 | 25 | \item{iterations}{integer: how many iterations to run equidistancing.} 26 | } 27 | \value{ 28 | matrix containing equidistantly placed points 29 | } 30 | \description{ 31 | make a curve equidistant (optionally up/downsampling) 32 | } 33 | \details{ 34 | Equidistancy is reached by iteratively deforming (using TPS) a straight line with equidistantly placed points to the target using control points with the same spacing as the actual curve. To avoid singularity, the straight line containes a small amount of noise, which can (optionally) be accounted for by smoothing the line by its neighbours. 35 | } 36 | \note{ 37 | if n >> number of original points, the resulting curves can show unwanted distortions. 38 | } 39 | \examples{ 40 | data(nose) 41 | x <- shortnose.lm[c(304:323),] 42 | xsample <- equidistantCurve(x,n=50,iterations=10,increment=2) 43 | \dontrun{ 44 | require(rgl) 45 | points3d(xsample,size=5) 46 | spheres3d(x,col=2,radius=0.3,alpha=0.5) 47 | } 48 | } 49 | -------------------------------------------------------------------------------- /man/histGroup.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/histGroup.r 3 | \name{histGroup} 4 | \alias{histGroup} 5 | \title{plot histogram for multiple groups.} 6 | \usage{ 7 | histGroup(data, groups, main = paste("Histogram of", dataname), 8 | xlab = dataname, ylab, col = NULL, alpha = 0.5, breaks = "Sturges", 9 | legend = TRUE, legend.x = 80, legend.y = 80, legend.pch = 15, 10 | freq = TRUE) 11 | } 12 | \arguments{ 13 | \item{data}{vector containing data.} 14 | 15 | \item{groups}{grouping factors} 16 | 17 | \item{main, xlab, ylab}{these arguments to title have useful defaults here.} 18 | 19 | \item{col}{vector containing color for each group. If NULL, the function 20 | "rainbow" is called.} 21 | 22 | \item{alpha}{numeric between 0 and 1. Sets the transparency of the colors} 23 | 24 | \item{breaks}{one of: \itemize{ 25 | \item a vector giving the breakpoints between histogram cells, 26 | \item a single number giving the number of cells for the histogram, 27 | \item a character string naming an algorithm to compute the number of cells (see \sQuote{Details}), 28 | \item a function to compute the number of cells. } In the last three cases the number is a suggestion only.} 29 | 30 | \item{legend}{logical: if TRUE, a legend is plotted} 31 | 32 | \item{legend.x}{x position of the legend from the upper left corner} 33 | 34 | \item{legend.y}{y position of the legend from the upper left corners} 35 | 36 | \item{legend.pch}{integer: define the symbol to visualise group colors 37 | (\code{\link{points}})} 38 | 39 | \item{freq}{logical: if TRUE, the histogram graphic is a representation of 40 | frequencies, the counts component of the result; if FALSE, probability 41 | densities are plotted for each group.} 42 | } 43 | \description{ 44 | plot a histogram for multiple groups, each group colored individually 45 | } 46 | \details{ 47 | Just a wrapper for the function hist from the "graphics" package 48 | } 49 | \examples{ 50 | 51 | data(iris) 52 | histGroup(iris$Petal.Length,iris$Species) 53 | 54 | 55 | } 56 | \seealso{ 57 | \code{\link{hist}} 58 | } 59 | \author{ 60 | Stefan Schlager 61 | } 62 | -------------------------------------------------------------------------------- /R/lineplot.r: -------------------------------------------------------------------------------- 1 | #' plot lines between landmarks 2 | #' 3 | #' add lines connecting landmarks to visualise a sort of wireframe 4 | #' 5 | #' 6 | #' @param x matrix containing 2D or 3D landmarks 7 | #' @param point vector or list of vectors containing rowindices of x, 8 | #' determining which landmarks to connect. 9 | #' @param col color of lines 10 | #' @param lwd line width 11 | #' @param line_antialias logical: smooth lines 12 | #' @param add logical: add to existing plot 13 | #' @note works with 2D and 3D configurations 14 | #' @author Stefan Schlager 15 | #' @seealso \code{\link{pcaplot3d}} 16 | #' 17 | #' @examples 18 | #' 19 | #' 20 | #' if (require(shapes)) { 21 | #' ##2D example 22 | #' plot(gorf.dat[,,1],asp=1) 23 | #' lineplot(gorf.dat[,,1],point=c(1,5:2,8:6,1),col=2) 24 | #' } 25 | #' ##3D example 26 | #' \dontrun{ 27 | #' require(rgl) 28 | #' data(nose) 29 | #' points3d(shortnose.lm[1:9,]) 30 | #' lineplot(shortnose.lm[1:9,],point=list(c(1,3,2),c(3,4,5),c(8,6,5,7,9)),col=2) 31 | #' } 32 | #' 33 | #' @export 34 | lineplot <- function(x,point,col=1,lwd=1,line_antialias = FALSE,add=TRUE) 35 | { 36 | 37 | if (dim(x)[2] == 3) 38 | { 39 | if (is.list(point)==TRUE) 40 | { 41 | for (i in 1:length(point)) 42 | { 43 | lines3d(x[point[[i]],1],x[point[[i]],2],x[point[[i]],3],col=col,lwd=lwd,line_antialias = line_antialias) 44 | } 45 | } 46 | else 47 | { 48 | lines3d(x[point,1],x[point,2],x[point,3],col=col,lwd=lwd,line_antialias = line_antialias) 49 | } 50 | } 51 | else 52 | { 53 | if (!add) 54 | { 55 | plot(x,asp=1,cex=0,xlab="x-coordinate",ylab="y-coordinate") 56 | } 57 | if (is.list(point)==TRUE) 58 | { 59 | for (i in 1:length(point)) 60 | { 61 | lines(x[point[[i]],1],x[point[[i]],2],col=col,lwd=lwd) 62 | } 63 | } 64 | else 65 | { 66 | lines(x[point,1],x[point,2],col=col,lwd=lwd) 67 | } 68 | } 69 | } 70 | --------------------------------------------------------------------------------