# make.template<-function(full, deci, file.name=NULL,sdir=getwd(),over.write=FALSE,...){
# # calls the function digit.mesh() to edit landmark on a reference mesh (target), and the function save.coo.matrix() to save the coordinates if a filename is provided
#
# A<-DigitFixed(full, deci, ...)
# if(!is.null(file.name)){
# save.tps(A, ID=file.name, file.name, sdir=sdir,over.write=over.write)
# }
#
# return(A)
#
# }
# TPS utilities -----
#' @title Saves 3D Coordinates into a TPS File
#' @description Saves landmark coordinates as generated by \code{\link{digitMesh.mesh3d}} into a TPS file. \cr
#' \strong{Note}: this is not a generic function to create TPS file, it's only designed for 3D landmark
#' data.
#' @details Given a matrix of landmark coordinates \code{A}, this function saves it into a TPS file whose filename is
#' contained into \code{file.name}.
#' @usage
#' save.tps(A, ID, file.name, LMheader = "LM3", IDheader = "ID",
#' sdir = getwd(), app = FALSE, over.write = FALSE)
#' @param A A 2D numerical matrix of landmark coordinates.
#' @param ID A character value containing the individual identifier.
#' @param file.name A character value containing the TPS file name (with extension).
#' @param LMheader A character value specifying the keyword to use in the TPS file to indicate the number of
#' landmarks. \cr
#' Default: \code{"LM3"}, for 3D landmarks.
#' @param IDheader A character value specifying the keyword to use in the TPS file to indicate the individual
#' identifier. \cr
#' Default: \code{"ID"}.
#' @param sdir A character value indicating the path to the saving directory. \cr
#' Default: \code{getwd()}.
#' @param app A logical value indicating if the written data should be appended in the TPS file (if this file already
#' exists). \cr
#' Default: \code{FALSE}.
#' @param over.write A logical value indicating if the file to save should overwrite the previous TPS file with the
#' same name (if it exists). \cr
#' Default: \code{FALSE}.
#' @return Nothing.
#' @seealso \code{\link{read.tps}}.
#' @export
#'
#' @examples
#'
#' # Generates first a 10*3 random matrix, just for illustration purpose,
#' # but such as it could be obtained after a mesh digitization:
#' M <- matrix(rnorm(30), 10, 3)
#' # Then, saves it as a TPS file:
#' save.tps(M, ID = "randomMatrix", file.name = "TPSfile4randomMatrix.tps")
#'
#'
save.tps<-function(A,ID,file.name,LMheader="LM3",IDheader="ID",sdir=getwd(),app=FALSE,over.write=FALSE){
# saves coordinates in matrix A into a TPS file
setwd(sdir)
lf<-list.files()
full.name<-paste(file.name,c(".tps","")[1+grepl(".tps",tolower(file.name))],sep="") # add the ".tps" extension if needed
if(!over.write & is.element(full.name,lf) & !app){
stop("A file with this name already exists... Please provide another file name, or allow the current file to be deleted (by setting the over.write arg to TRUE)")
}else{
p<-nrow(A)
write(paste0(paste0(LMheader,"="),p),full.name,append=app)
write(t(A),full.name,ncolumns=3,append=TRUE)
write(paste0(paste0(IDheader,"="),ID),full.name,append=TRUE)
}
}
#' @title Reads 3D Coordinates from a TPS File
#' @description Reads landmark coordinates stored in a TPS file as generated by \code{\link{save.tps}}. \cr
#' \strong{Note}: this is not a generic function to read TPS file, it's only designed for TPS file
#' storing 3D landmark data. For more generic function, see \emph{e.g.}:
#' \code{\link[geomorph]{readland.tps}}, \code{\link[Momocs]{import_tps}} or
#' \code{\link[Morpho]{readallTPS}}.
#' @details Given a TPS filename (\code{file.name}) contained in the \code{sdir} directory, this functions extracts 3D
#' landmark coordinates (possibly scales them), and stores them into an array (landmarks by lines,
#' dimensions=3 by columns, and individual by slices).
#' @usage
#' read.tps(file.name, sdir = getwd(), LMheader = "LM3",
#' IDheader = "ID", SCheader = "SCALE", k = 3, quiet = FALSE)
#' @param file.name A character value containing the TPS file name (with extension).
#' @param sdir A character value indicating the path to the saving directory. \cr
#' Default: \code{getwd()}.
#' @param LMheader A character value specifying the keyword to use in the TPS file to indicate the number of
#' landmarks. \cr
#' Default: \code{"LM3"}, for 3D landmarks.
#' @param IDheader A character value specifying the keyword to use in the TPS file to indicate the individual
#' identifier. \cr
#' Default: \code{"ID"}.
#' @param SCheader A character value specifying the keyword to use in the TPS file to indicate the scale
#' identifier. \cr
#' Default: \code{"SC"}.
#' @param k A numercial value (positive integer) indicating the dimensions of data. \cr
#' Default: \code{3}.
#' @param quiet A logical value indicating if a line should be printed when the tps file is opened (see
#' \code{\link[base]{scan}}).
#'
#' @return A \emph{p*k*n} numerical array (\emph{p}: nb of landmarks, \emph{k}: nb of dimensions, \emph{n}: number
#' of individuals).
#' @seealso \code{\link{save.tps}}.
#' @export
#'
#' @examples
#'
#' # Generates first two 10*3 random matrices, just for illustration purpose,
#' # but such as it could be obtained after two mesh digitizations:
#' M <- matrix(rnorm(30), 10, 3)
#' N <- matrix(rnorm(30), 10, 3)
#' # Then, saves them as a TPS file:
#' save.tps(M, ID = "randomMatrix_M", file.name = "TPSfile4randomMatrix.tps")
#' save.tps(N, ID = "randomMatrix_N", file.name = "TPSfile4randomMatrix.tps", app=TRUE)
#' # And finally, read it:
#' A <- read.tps("TPSfile4randomMatrix.tps")
#'
read.tps<-function(file.name,sdir=getwd(),LMheader="LM3",IDheader="ID", SCheader="SCALE",k=3, quiet = FALSE){
# read coordinates from a TPS file
setwd(sdir)
quiet<-checkLogical(quiet,1)
full.name<-paste(file.name,c(".tps","")[1+grepl(".tps",tolower(file.name))],sep="")
tmp<-scan(full.name,what="character",quiet=quiet)
idxID<-which(startsWith(tmp,paste0(IDheader,"=")))
ID<-unlist(lapply(strsplit(tmp[idxID],"="),f<-function(L){L[[2]]}))
n<-length(ID)
idxSc<-which(startsWith(tmp,paste0(SCheader,"=")))
Sc<-unlist(lapply(strsplit(tmp[idxSc],"="),f<-function(L){L[[2]]}))
Sc<-as.numeric(Sc)
isScale<-FALSE
if (length(Sc)>0){
isScale<-TRUE
}
idxLM<-which(startsWith(tmp,paste0(LMheader,"=")))
p<-unlist(lapply(strsplit(tmp[idxLM],"="),f<-function(L){L[[2]]}))
p<-unique(as.numeric(p))
if (length(p)>1){
stop("Not consistent landmark number through the TPS file...")
}else{
A<-array(0,c(p,k,n))
for (i in 1:n){
ind<-as.numeric(tmp[(idxLM[i]+1):(idxLM[i]+k*p)])
if (isScale){
ind<-ind*Sc[i]
}
A[,,i]<-matrix(ind,p,k,byrow=TRUE)
}
n0<-nchar(as.character(p))-nchar(as.character(1:p))
v0<-lapply(n0,f<-function(v,i){rep(0,v[1])})
v0<-as.character(v0)
v0[v0=="numeric(0)"]<-""
dimnames(A)<-list(paste0("lm_", v0, 1:p), c("x","y","z")[1:k], ID)
return(A)
}
}
# checking ID, color, alpha etc... --------------
checkOsGui <- function(winNb, winSynchro) {
# check OS and R GUI
os <- Sys.info()[1]
gui <- .Platform$GUI
if (os == "Darwin"){
if (gui == "RStudio"){
# not supported
stop("The function is not supported with the RStudio interface in Mac OS
Please, use the R gui instead.")
} else{
# in Mac OS only 2 separate windows are supported
# => forcing graphic options...
if (winNb == 1){
warning('with mac OS, multiple interactive subscenes are not supported.
winWb option was set to 2')
winNb <- 2
winSynchro <- FALSE
}
}
}
return(list(winNb, winSynchro))
}
checkID<-function(ID1,ID2){
if (length(ID1)!=length(ID2)){
extra.full<-setdiff(ID1,ID2) # full sans deci
extra.deci<-setdiff(ID2,ID1) # deci sans full
cat("\n")
if (as.logical(length(extra.full))){
cat("The following files for full meshes miss equivalent files for decimated meshes:")
cat(extra.full,sep="\n")
}
if (as.logical(length(extra.deci))){
cat("The following files for decimated meshes miss equivalent files for full meshes:")
cat(extra.deci,sep="\n")
}
stop("Mismatch between files of full and decimated meshes...")
}else{
if(identical(ID1,ID2)){
ID<-ID1
}else{
extra.full<-setdiff(ID1,ID2) # full sans deci
extra.deci<-setdiff(ID2,ID1) # deci sans full
cat("\n")
if (as.logical(length(extra.full))){
cat("The following files for full meshes miss equivalent files for decimated meshes:")
cat(extra.full,sep="\n")
}
if (as.logical(length(extra.deci))){
cat("The following files for decimated meshes miss equivalent files for full meshes:")
cat(extra.deci,sep="\n")
}
stop("Mismatch between files of full and decimated meshes...")
}
}
return(ID)
}
checkColor<-function(M,message=as.character(deparse(substitute(M)))){
t1<-is.element(c(M),colors())
if (sum(t1)<length(t1)){
stop(paste0(message," should be chosen within the values from colors()..."))
}
}
checkAlpha<-function(M,message=as.character(deparse(substitute(M)))){
if (!is.numeric(M) | any(is.na(M))){
stop(paste0(message," should contain numeric values..."))
}
if (min(M)<0 | max(M)>1){
stop(paste0(message," should contain values in [0,1]..."))
}
}
checkLength<-function(M,len,message=as.character(deparse(substitute(M))),repV=TRUE){
if (!is.element(length(M),len)){
stop(paste0(message," should have length within {",paste(len,collapse=","),"}..."))
}
if (repV & length(M)>1 & length(M)<max(len)){
stop(paste0(message," should have length within {",paste(range(len),collapse=","),"}..."))
}
if (repV & length(M)==1){
M<-rep(M,max(len))
}
return(M)
}
checkLogical<-function(M,len,message=as.character(deparse(substitute(M)))){
if(!is.logical(M) | any(is.na(M))){
stop(paste0(message," should contain logical values..."))
}
M<-checkLength(M,len,message=message)
return(M)
}
checkMat<-function(M,message=as.character(deparse(substitute(M)))){
#?! (see Algebraic notation (chess) for meaning...)
if (!any(is.element(class(M),c("matrix","numeric","character")))){
stop(paste0(message," should be either a matrix or vector..."))
}
if (length(M)>4 | length(M)==3){
stop(paste0("Wrong value number specified for ",message,"..."))
}
if (length(M)==1){
M<-matrix(M,2,2)
}
if (length(M)==2){
M<-matrix(c(M),2,2)
}
return(M)
}
# Set Options -----
#' @title Sets Graphic Options
#' @description Set graphic options for \code{\link{digitMesh.mesh3d()}} and \code{\link{digitMesh.character()}}.
#' @details This function allows user to set several parameters for graphical rendering for the landmark digitization
#' process performed through the call of either \code{\link{digitMesh.mesh3d()}} or
#' \code{\link{digitMesh.character()}}. With no arguments, this function returns the default settings for
#' graphic options. Any of those options can be modified by setting new values for the corresponding
#' arguments. Non-filled arguments will be set to default. Ill-filled arguments will return errors or
#' warnings.
#'
#' The arguments for graphic options are categorized by themes, and concerns: \strong{window options},
#' \strong{mesh rendering options}, \strong{major plane options}, \strong{mesh/major plane intersection
#' options}, \strong{sphere options}, \strong{labelling options} and \strong{zoom options}.
#'
#' - the \strong{window options} allow to set the number of grahical devices (\code{winNb}), their size and
#' positioning (\code{winSize}) and the synchronization or not between full and decimated meshes of the
#' user action (rotation, zoom: \code{winSynchro});
#'
#' - the \strong{mesh rendering options} allow to play on mesh color (\code{meshColor}), its transparency
#' (\code{meshAlpha}), its mode of representation (shading for \code{meshShade}, 3D points for
#' \code{meshPoints}, 3D wire for \code{meshWire});
#'
#' - the \strong{major plane options} allow to perform or not the preliminary step of major plane adjustement
#' before landmark digitization (\code{PCplanesDraw}), to set their color and transparency (
#' \code{PCplanesColor}, \code{PCplanesAlpha});
#'
#' - the \strong{mesh/major plane intersection options} allow to set the mode of representation for the
#' intersection lines among major planes and mesh (via 3D lines for \code{intersectLines} or 3D points
#' for \code{intersectPoints}) and their color (code{intersectColor});
#'
#' - the \strong{sphere options} for landmark rendering allow to set their radius (\code{spheresRad}),
#' their color (\code{spheresColor}), and their transparency (\code{spheresAlpha});
#'
#' - the \strong{labelling options} for landmark numbering allow to set their size (\code{labelCex}),
#' their color (\code{labelColor}) and their adjustment relative to the sphere (\code{labelAdj});
#'
#' - the \strong{zoom options} allow to set the extent of the zoomed area (\code{zoomPercDist}), to project
#' or not on the decimated mesh this extent (\code{zoomPtsDraw}) and to set its color (\code{zoomPtsCol}),
#' to display or not on the full mesh the landmark pre-positionned on the decimated mesh
#' (\code{zoomSeeLm}), and to display or not on the full mesh the already positionned landmarks
#' (\code{zoomSeePrevLm}).
#' @usage
#' setGraphicOptions(winNb=1, winSize= rbind(c(0,50,830,904), c(840,50,1672,904)), winSynchro=TRUE,
#' meshVertCol=TRUE, meshColor=rep("gray",2), meshAlpha=rep(1,2), meshShade=rep(TRUE,2),
#' meshPoints=c(FALSE,TRUE), meshWire=rep(FALSE,2),
#' PCplanesDraw=FALSE, PCplanesColor= "cyan", PCplanesAlpha=0.7,
#' intersectLines=TRUE, intersectPoints=FALSE, intersectColor="red",
#' spheresRad=0.02, spheresColor=matrix(c("black","blue"),2,2), spheresAlpha=1,
#' labelCex=2, labelColor="magenta", labelAdj=0.02,
#' zoomPercDist=0.15, zoomPtsDraw=TRUE, zoomPtsCol="orange", zoomSeeLm=FALSE, zoomSeePrevLm=TRUE)
#'
#' @param winNb A numeric value within \{\code{1},\code{2}\} setting for the number of grahical devices: \cr
#' - \code{1} (default) for a single device subdivided into 2 parts (one for the decimated mesh, the
#' other for the zoomed mesh); \cr
#' - \code{2} for two separate devices. \cr
#' \strong{Warning}: For Mac users, only the setting with 2 separate devices is supported. The OS will be
#' automatically detected when calling the \code{digitMesh()} function and \code{winNb}
#' will be force to be 2 in case of a call from a Mac OS. \cr
#' @param winSize A vector or matrix indicating the size and positioning of graphical device(s): \cr
#' - a vector with 4 positive values indicating the left, top, right and bottom (in pixels, see the
#' help for the \code{windowRect} parameter in \code{\link[rgl]{par3d}} for the device (when
#' \code{winNb=1}); \cr
#' - a 2*4 matrix of positive values, each line indicating as before the left, top, right and bottom
#' (in pixels) for each device (when \code{winNb=2}).
#' @param winSynchro A logical value indicating if user interaction (zoom, rotation) applied on a mesh should be
#' synchronously applied on the second one (decimated or full mesh). Only Works for \code{winNb=1}.
#' \cr
#' Default: \code{TRUE} for synchronization.
#' @param meshVertCol A logical value indicating if the original vertex colors should be kept (\code{TRUE}) or not
#' (\code{FALSE}). In the last case, a uniform color specified by the \code{meshColor} will be
#' used.
#' @param meshColor A character vector of length 1 or 2 indicating the color(s) for mesh plotting. Values for
#' \code{meshColor} should be taken from \code{\link[grDevices]{colors}}(). A 1-length vector will
#' apply the same color for full and decimated mesh, and a 2-length will apply the first color for
#' the decimated mesh and the second one for the full mesh. \cr
#' \strong{Note}: for the \code{meshShade} and the \code{meshWire} options, but not for the
#' \code{meshPoints} option (see details after), this color won't overwrite the color
#' stored in the \code{material$color} (if any) from the \code{mesh3d} object for
#' plotting. This color will be used only if the \code{material$color} is \code{NULL}.
#' \cr
#' Default: \code{rep("gray",2)} => both meshes in gray.
#' @param meshAlpha A character vector of length 1 or 2 indicating the alpha value(s) (transparency) for mesh
#' plotting. It will overwrite the alpha value stored in \code{material$alpha} (if any). Values for
#' \code{meshAlpha} should be taken within [0,1]. A 1-length vector will apply the same alpha for
#' full and decimated mesh, and a 2-length vector will apply the first alpha for the decimated mesh
#' and the second one for the full mesh. \cr
#' Default: \code{rep(1,2)} => both meshes totally opaque.
#' @param meshShade Logical vector of length 1 or 2 indicating if the meshes should be plotted or not via
#' \code{\link[rgl]{shade3d}}. \code{TRUE} value will use \code{\link[rgl]{shade3d}}, and
#' \code{FALSE} won't. A 1-length vector will apply the same value for both meshes and a 2-length
#' will apply the first value for decimated mesh, and the second one for full mesh. \cr
#' \strong{Note}: each mesh should be plotted through one of the 3 possible representations (
#' \code{meshShade}, \code{meshPoints}, \code{meshWire}), meaning that at least one
#' \code{TRUE} value in this parameter is needed for each mesh. If not filled,
#' \code{meshShade} will be automatically set to \code{TRUE}. \cr
#' Default: \code{rep(TRUE,2)} to use \code{\link[rgl]{shade3d}} for both meshes.
#' @param meshPoints Identical to \code{meshShade} to plot the mesh using using \code{\link[rgl]{points3d}}. \cr
#' Default: \code{c(FALSE,TRUE)} to use \code{\link[rgl]{points3d}} only for the full mesh.
#' @param meshWire Identical to \code{meshShade} to plot the mesh using \code{\link[rgl]{wire3d}}. \cr
#' Default: \code{rep(FALSE,2)} to not use \code{\link[rgl]{wire3d}} for both meshes.
#' @param PCplanesDraw A 1-length logical or a character vector of length 1, 2 or 3 indicating if major planes (from
#' mesh principal components) as well as their intersections with the mesh should be plotted, and
#' interactively set by user before the landmark digitizing step. Possible settings: \cr
#' - \code{TRUE} (or \code{FALSE}): in this case all (or no one of) the 3 major planes will be (or
#' won't be) plotted; \cr
#' - any combination of the values within \{\code{"pc1-pc2"},\code{"pc1-pc3"},\code{"pc2-pc3"}\}
#' indicating which particular plane(s) should be plotted. \cr
#' Default: \code{FALSE} to not draw the planes and their intersections.
#' @param PCplanesColor A character vector taking values within \code{\link[grDevices]{colors}}() indicating with which
#' color each plane should be plotted. If only one value is given for more than one plane, the
#' color value is recycled. Otherwise, this vector should have the same length than the number of
#' plotted planes. \cr
#' Default: \code{"cyan"}.
#' @param PCplanesAlpha A numerical vector taking values within [0,1] indicating with which transparency (alpha value)
#' each plane should be plotted. If only one value is given for more than one plane, the alpha
#' value is recycled. Otherwise, this vector should have the same length than the number of
#' plotted planes. \cr
#' Default: \code{0.7}.
#' @param intersectLines A logical vector indicating for each intersection plane if the \code{\link[rgl]{lines3d}}
#' mode of representation should be use to figure the mesh/major plane intersection. If only one
#' value is given for more than one plane, the logical value is recycled. Otherwise, this vector
#' should have the same length than the number of plotted planes. \cr
#' \strong{Note 1}: each intersection should be plotted through one of the 2 possible
#' representations (\code{intersectLines},\code{intersectPoints}), meaning that
#' at least one \code{TRUE} value in this parameter is needed for each mesh. If
#' no, \code{intersectLines} will be automatically set to \code{TRUE}. \cr
#' \strong{Note 2}: for big meshes, the intersection plotting can be fasten by setting
#' \code{intersectLines} to \code{FALSE}. \cr
#' Default: \code{TRUE}.
#' @param intersectPoints Identical to \code{intersectLines} to plot the interstions using \code{\link[rgl]{points3d}}.
#' \cr
#' Default: \code{FALSE}.
#' @param intersectColor A character vector taking values within \code{\link[grDevices]{colors}}() indicating with
#' which color each intersection should be plotted. If only one value is given for more than one
#' plane, the color value is recycled. Otherwise, this vector should have the same length than
#' the number of plotted planes. \cr
#' Default: \code{"red"}.
#' @param spheresRad A numerical vector or matrix taking values within [0,1] indicating with which radius the spheres
#' figuring the landmarks should be plotted. Actually, the radius is expressed as a fraction of the
#' mesh dimensions(so better values are close to 0). Possible settings: \cr
#' - a 2*2 matrix, the 1st line corresponding to the setting before user validation and the 2nd one
#' after, the 1st column correspondng to the setting for the decimated mesh and the second one for
#' the zoomed full mesh; \cr
#' - a vector of length 2 corresponding to the setting before user validation and the 2nd one after
#' (those values will be recycled for the full mesh); \cr
#' - a unique value for the setting before and after the user validation, and for the decimated and
#' the full mesh. \cr
#' Default: \code{0.01}.
#' @param spheresColor A character vector or matrix taking values within \code{\link[grDevices]{colors}}() indicating
#' with which color the spheres figuring the landmarks should be plotted. See \code{spheresRad}
#' for possible settings. \cr
#' Default: \code{matrix(c("black","blue"),2,2)} to plot on both meshes spheres in black while the
#' landmark has not been validated, and in blue after.
#' @param spheresAlpha A numerical vector or matrix taking values within [0,1] indicating with which transparency
#' (alpha value) the spheres figuring the landmarks should be plotted. See \code{spheresRad} for
#' possible settings. \cr
#' Default: \code{1} (no transparency for spheres).
#' @param labelCex A numerical vector or matrix taking positive values indicating with which size the landmark labels
#' should be plotted. See See \code{spheresRad} for possible settings. \cr
#' Default: \code{2}.
#' @param labelColor A character vector or matrix taking values within \code{\link[grDevices]{colors}}() indicating
#' with which color the landmark labels should be plotted. See spheresRad for possible settings. \cr
#' Default: "magenta".
#' @param labelAdj A numerical vector or matrix or array taking values within [0,1] indicating how to adjust the label
#' location relative to the landmark sphere. Possible settings: \cr
#' - a 2*2*2 array, the 1st line corresponding to the setting before user validation and the 2nd one
#' after, the 1st column correspondng to the setting for the decimated mesh and the second one for
#' the full mesh, the first slice corresponding to the horizontal adjustment and the second one to
#' the vertical adjustment; \cr
#' - a 2*2 matrix corresonding to the slide for horizontal adjustment which will be recycled for
#' vertical adjustment; \cr
#' - a vector of length 2 corresponding to the setting before user validation and the 2nd one after
#' (those values will be recycled for the full mesh and the vertical adjustment); \cr
#' - a unique value for the setting before and after the user validation (recycled for the full mesh
#' and the vertical adjustment). \cr
#' Default: \code{0.02}.
#' @param zoomPercDist A numerical value within [0,1] specifying the extent of the zoomed full mesh. This extent is
#' computed as the maximal distance between the clicked point and the mesh points multiplied by
#' \code{zoomPercDist}. \cr
#' Default: \code{0.15}.
#' @param zoomPtsDraw A logical value indicating if the exent of the zoomed mesh should be shown on the decimated mesh.
#' This extent will be represented as a 3D point cloud. \cr
#' Default: \code{TRUE}.
#' @param zoomPtsCol A character value taking values within \code{\link[grDevices]{colors}}() indicating with which
#' color the zoom extent (if \code{zoomPtsDraw} is set to \code{TRUE}) should be plotted. \cr
#' Default: \code{"orange"}.
#' @param zoomSeeLm A logical value indicating if the landmark placed by the user on the decimated mesh should be visible
#' on the zoomed mesh. It will slightly fasten the process of the landmark digitizing enabling the
#' direct validation (without any manual change) of the placed landmark, but at the risk of a more or
#' less important approximation on the landmark positioning depending on the degree of decimation
#' used for the decimated mesh. \cr
#' Default: \code{FALSE}.
#' @param zoomSeePrevLm A logical value indicating if the landmarks already placed by the user should be visible
#' on the zoomed mesh if they are located in the zoom extent. \cr
#' Default: \code{TRUE}.
#'
#' @return A list of those parameters gathered in sublists following the thematic categorization described above.
#' @seealso \code{\link{setDecimOptions}}, \code{\link{setFileOptions}}, \code{\link{setTemplOptions}}.
#' @export
#' @examples
#' # returning default settings:
#' GrOpt<-setGraphicOptions()
#'
#' # some possible settings (not exhaustive):
#' GrOpt<-setGraphicOptions(winNb=2, winSynchro= FALSE, PCplanesDraw=c("pc2-pc3"))
#' GrOpt<-setGraphicOptions(meshColor=c("gray","orange"), meshPoints=FALSE, zoomSeeLm=TRUE)
#' #...
#'
setGraphicOptions <- function(winNb = 1,
winSize = rbind(c(0, 50, 830, 904), c(840, 50, 1672, 904)),
winSynchro = TRUE,
meshVertCol = TRUE, meshColor = rep("gray",2),
meshAlpha = rep(1,2), meshShade = rep(TRUE, 2),
meshPoints = c(FALSE, FALSE), meshWire = rep(FALSE, 2),
PCplanesDraw = FALSE, PCplanesColor = "cyan", PCplanesAlpha = 0.7,
intersectLines = TRUE, intersectPoints = FALSE, intersectColor = "red",
spheresRad = 1e-2, spheresColor = matrix(c("black", "blue"), 2, 2), spheresAlpha = 1,
labelCex = 2, labelColor="magenta", labelAdj = 2e-2,
zoomPercDist = 0.15, zoomPtsDraw = TRUE,
zoomPtsCol = "orange", zoomSeeLm = FALSE, zoomSeePrevLm = TRUE) {
# Allow to set graphical options for DigitFixed.
# The simplest use with no argument returns a list with default values for all settable parameters:
warn <- options()$warn
options(warn = 1)
# Window options
if (!is.numeric(winNb) | length(winNb) != 1 | !is.element(winNb[1], c(1, 2))){
stop("winNb should be a scalar taking values in {1,2}...")
}
if (!is.element(length(winSize), c(4, 8))){
message<-paste("With ", winNb, " windows, winSize should contain ", 4*winNb, " integer values...", sep="")
stop(message)
}
if (min(winSize) < 0 | !is.numeric(winSize) | any(is.na(winSize))){
stop("winSize should contain positive integer values...")
}
if (!all(floor(winSize) == winSize, na.rm = TRUE)){
stop("winSize should contain positive integer values...")
}
# checking for osx/Rstudio
tmp <- checkOsGui(winNb, winSynchro)
winNb <- tmp[[1]]
winSynchro <- tmp[[2]]
if (!is.logical(winSynchro) | is.na(winSynchro)){
stop("winSynchro should be a logical value...")
}
if (winNb == 2 & winSynchro){
winSynchro <- FALSE
warning("With 2 separate windows, winSynchro=TRUE is not supported... Set to FALSE")
}
if (winNb == 2 & length(winSize) == 4){
tmp <- winSize
winSize <- rbind(tmp, tmp + c(tmp[3], 0, tmp[3], 0))
warning(paste0("The size and position for the second window wasn't specified... Set to: c(",toString(winSize[2,]),")"))
}
winSize <- matrix(c(t(winSize))[1:(4*winNb)], nrow = winNb, ncol = 4, byrow = TRUE)
if (min(winSize[, 3] - winSize[, 1]) <= 0 | min(winSize[, 4] - winSize[, 2]) <= 0){
stop("Wrong specification for winSize: see the help for windowRect parameter in rgl:::par3d for details")
}
winOptions <- list(winNb = winNb, winSize = winSize, winSynchro = winSynchro)
# mesh options
meshVertCol <- checkLogical(meshVertCol, 1)
checkColor(meshColor)
meshColor <- checkLength(meshColor, c(1, 2))
checkAlpha(meshAlpha)
meshAlpha <- checkLength(meshAlpha, c(1, 2))
meshShade <- checkLogical(meshShade, c(1, 2))
meshPoints <- checkLogical(meshPoints, c(1, 2))
meshWire <- checkLogical(meshWire, c(1, 2))
Sm <- meshShade + meshPoints + meshWire
if (min(Sm) == 0){
meshShade <- rep(TRUE, 2)
warning("Some mesh plot modes are missing! meshShade will be set to TRUE for both windows...")
}
meshOptions <- list(meshVertCol = meshVertCol, meshColor = meshColor,
meshAlpha = meshAlpha, meshShade = meshShade,
meshPoints = meshPoints, meshWire = meshWire)
# PC planes options
stopMessage <- "PCplanesDraw should be a logical value, or a character vector taking value within {\"pc1-pc2\",\"pc1-pc3\",\"pc2-pc3\"}..."
if (any(is.na(PCplanesDraw))){
stop(stopMessage)
}
if (!is.character(PCplanesDraw) & !is.logical(PCplanesDraw)){
stop(stopMessage)
}
PCplanesDraw <- checkLength(PCplanesDraw, 1:3, repV = FALSE)
if (is.logical(PCplanesDraw) & length(PCplanesDraw)==1){
nbPlanes <- 0
if (PCplanesDraw){
nbPlanes <- 3
}
} else {
if (is.logical(PCplanesDraw)) {
stop(stopMessage)
}
V <- c("pc2-pc3", "pc1-pc3", "pc1-pc2")
t1 <- is.element(PCplanesDraw, V)
nbPlanes <- sum(t1)
if (sum(t1) != length(t1)) {
stop(stopMessage)
}
}
if (nbPlanes>0) {
checkColor(PCplanesColor)
PCplanesColor <- checkLength(PCplanesColor, 1:nbPlanes)
checkAlpha(PCplanesAlpha)
PCplanesAlpha <- checkLength(PCplanesAlpha, 1:nbPlanes)
} else {
PCplanesColor <- PCplanesAlpha <- NULL
}
PCplanesOptions <- list(PCplanesDraw = PCplanesDraw, PCplanesColor = PCplanesColor,
PCplanesAlpha = PCplanesAlpha)
# intersect options
if (nbPlanes > 0) {
intersectLines <- checkLogical(intersectLines, 1:nbPlanes)
intersectPoints <- checkLogical(intersectPoints, 1:nbPlanes)
if (sum(intersectLines) == 0 & sum(intersectPoints) == 0){
intersectLines <- rep(TRUE,nbPlanes)
warning("To be visible, mesh/plane intersections should plotted at least by lines: instersectLines was set to TRUE...")
}
checkColor(intersectColor)
intersectColor <- checkLength(intersectColor, 1:nbPlanes)
} else {
intersectLines <- intersectPoints <- FALSE
intersectColor <- NULL
}
intersectOptions <- list(intersectLines = intersectLines,
intersectPoints = intersectPoints,
intersectColor = intersectColor)
# sphere options
if (!is.numeric(spheresRad) | any(spheresRad < 0)){
stop("spheresRad should contained positive numerical values...")
}
if (max(spheresRad)>1){
warning("spheresRad should be a fractional number < 1 to allow readable plots")
}
spheresRad <- checkMat(spheresRad)
checkColor(spheresColor)
spheresColor <- checkMat(spheresColor)
checkAlpha(spheresAlpha)
spheresAlpha <- checkMat(spheresAlpha)
spheresOptions <- list(spheresRad = spheresRad, spheresColor = spheresColor,
spheresAlpha = spheresAlpha)
# label options
if (any(is.na(labelCex))){
stop("labelCex should contained numerical values...")
}
if (!is.numeric(labelCex) | min(labelCex)<0){
stop("labelCex should contained positive numerical values...")
}
labelCex <- checkMat(labelCex)
checkColor(labelColor)
labelColor <- checkMat(labelColor)
if (!is.numeric(labelAdj) | any(is.na(labelAdj))){
stop("labelAdj should be numeric...")
}
if (is.element(length(labelAdj),c(1,2,4))){
labelAdj <- array(rep(c(labelAdj), 8/length(labelAdj)), dim = c(2, 2, 2))
} else if(!identical(dim(labelAdj), as.integer(c(2, 2, 2)) )){
stop("labelAdj should be a 2*2*2 array or a vector/matriw with 1, 2 or 4 values...")
}
if (max(labelAdj) > 1){
warning("labelAdj should contain fractional values to allow readable plots")
}
labelOptions <- list(labelCex = labelCex, labelColor = labelColor, labelAdj = labelAdj)
# zoom options
if (length(zoomPercDist) != 1 | !is.numeric(zoomPercDist) | min(zoomPercDist) < 0 | max(zoomPercDist) > 1){
stop("zoomPercDist should be a numerical value between 0 and 1...")
}
if (length(zoomPtsDraw) != 1 | !is.logical(zoomPtsDraw) | any(is.na(zoomPtsDraw))){
stop("zoomPtsDraw should be a logical value...")
}
if (zoomPtsDraw) {
if (length(zoomPtsCol) != 1 | any(!is.element(zoomPtsCol, colors()))){
stop("zoomPtsCol should be a unique value chosen within the values from colors()...")
}
} else {
zoomPtsCol <- NULL
}
if (length(zoomSeeLm) != 1 | !is.logical(zoomSeeLm) | any(is.na(zoomSeeLm))){
stop("zoomSeeLm should be a logical value...")
}
if (length(zoomSeePrevLm) != 1 | !is.logical(zoomSeePrevLm) | any(is.na(zoomSeePrevLm))){
stop("zoomSeePrevLm should be a logical value...")
}
zoomOptions <- list(zoomPercDist = zoomPercDist, zoomPtsDraw = zoomPtsDraw,
zoomPtsCol = zoomPtsCol, zoomSeeLm = zoomSeeLm, zoomSeePrevLm = zoomSeePrevLm)
options(warn = warn)
return(list(winOptions = winOptions, meshOptions = meshOptions,
PCplanesOptions = PCplanesOptions, intersectOptions = intersectOptions,
spheresOptions = spheresOptions, labelOptions = labelOptions,
zoomOptions = zoomOptions))
}
#' @title Sets File Options
#' @description Set file options (opening and saving) for \code{\link{digitMesh.character}}.
#' @details This function allows user to set several parameters for mesh file opening and saving as well as TPS export
#' needed during the call of \code{\link{digitMesh.character}}. With no arguments, this function returns the
#' default settings for file options. Any of those options can be modified by setting new values for the
#' corresponding arguments. Non-filled arguments will be set to default. Ill-filled arguments will return
#' errors or warnings.
#'
#' Depending on the user choice to perform the mesh decimation either during the mesh digitization, or to use
#' already decimated meshes, the options linked to the decimated mesh (\code{deci.suffix}, \code{deci.dir})
#' will concern either the saving of those meshes, or their opening.
#'
#' Additionnally to the provided parameters, this function will return the information of the directory
#' containing the full mesh(es) as well as the filename(s) of full mesh(es) to treat.
#' @usage
#' setFileOptions(M, sdir=getwd(), patt=".ply", deci.suffix=NULL, deci.dir="DecimMesh",
#' saveTPS="", overwrite=FALSE , append=FALSE)
#' @param M A character value indicating either a mesh filename (with extension) contained in \code{sdir}, or a
#' subdirectory name (not a path) contained in \code{sdir} in which a set of mesh files should be processed
#' for digitization.
#' @param sdir A character value indicating the path for the directory containing either the mesh to digitize or the
#' subdirectory containing the mesh files to digitize. \cr
#' Default: \code{getwd()} => working directory.
#' @param patt A character value within \{\code{".ply"},\code{".stl"}\} indicating the kind of mesh file to open. \cr
#' Default: \code{".ply"}.
#' @param deci.suffix A character value indicating the suffix added (or to add) at the end of the decimated mesh
#' filenames and before the exension. \cr
#' Default: \code{NULL}.
#' @param deci.dir A character value indicating the name of the subdirectory in \code{M} where the decimated mesh will
#' be saved or extracted. By default, \code{deci.dir} is set to \code{"DecimMesh"}, meaning that a
#' subdirectory named \code{"DecimMesh"} will be automatically created within \code{M} (if it doesn't
#' exist yet).
#' @param saveTPS Either a character value indicating the name (with extension) for the TPS filename to export
#' landmark coordinates, or a \code{FALSE} value if user don't want save coordinate. The TPS file will
#' be saved within the directory specified by \code{M}. \cr
#' Default: \code{""} indicates that the tps filename will be set depending on the processed mesh or directory (\code{M}).
#' @param overwrite A logical value taking values within \{\code{TRUE},\code{FALSE}\} indicating if the TPS file shoud
#' be overwritten if the provided filename already exists. \cr
#' Default: \code{FALSE} => will generate an error if the file aready exists...
#' @param append A logical value taking values within \{\code{TRUE},\code{FALSE}\} indicating if the landmark
#' coordinates should be appended in the TPS file (it could be the case when user need to digitize a set
#' of meshes in several session but want to store all results in the same file). \cr
#' Default: \code{FALSE}.
#' @return A list of those parameters plus the information of the directory containing the full mesh(es) (
#' \code{full.dir}, as a character value) and the filename(s) of full mesh(es) to treat (\code{full.files}
#' as a character vector).
#' @seealso \code{\link{setDecimOptions}}, \code{\link{setGraphicOptions}}, \code{\link{setTemplOptions}}.
#' @export
#'
setFileOptions<-function(M, sdir = getwd(), patt = ".ply", deci.suffix = NULL,
deci.dir = "DecimMesh", saveTPS = "",
overwrite = FALSE , append = FALSE) {
curdir <- getwd()
# various checkings
M <- checkLength(M,1)
if (!is.character(M)) {
stop("M should be a string...")
}
M <- rev(strsplit(M, "/")[[1]])[1]
sdir <- checkLength(sdir,1)
if (!is.character(sdir) | !dir.exists(sdir)) {
stop("sdir should be a valid path name...")
}
deci.suffix <- checkLength(deci.suffix,0:1)
if (!is.null(deci.suffix) & !is.character(deci.suffix)) {
stop("deci.suffix should be either null or a string...")
}
deci.dir <- checkLength(deci.dir, 0:1)
if (!is.null(deci.dir) & !is.character(deci.dir)) {
stop("deci.dir should be either null or a string...")
}
deci.dir <- rev(strsplit(deci.dir, "/")[[1]])[1]
if (is.null(deci.suffix) & is.null(deci.dir)) {
stop("At least one of the following arguments should be provided: deci.suffix or deci.dir...")
}
saveTPS <- checkLength(saveTPS,1)
if (!is.character(saveTPS)) {
stop("saveTPS should be a string...")
}
# determination of full.dir, full.files and deci.dir
setwd(sdir)
if (dir.exists(M)){
if (nchar(saveTPS) < 1){
saveTPS <- M
}
full.dir <- paste(getwd(), M, sep = "/")
setwd(full.dir)
full.files <- list.files(pattern = patt, ignore.case = TRUE)
if (!is.null(deci.dir)) {
if (!dir.exists(deci.dir)) {
dir.create(deci.dir)
}
deci.dir <- paste(full.dir, deci.dir, sep = "/")
} else {
deci.dir <- full.dir
}
} else {
if (file.exists(M)) {
full.files <- M
if (is.null(deci.dir)) {
full.dir <- deci.dir <- sdir
} else {
full.dir <- sdir
setwd(full.dir)
if (!dir.exists(deci.dir)) {
dir.create(deci.dir)
}
deci.dir <- paste(full.dir, deci.dir, sep = "/")
}
if (nchar(saveTPS) < 1){
saveTPS <- paste(rev(rev(strsplit(M,"\\.")[[1]])[-1]), collapse = ".")
}
} else {
stop("Provided filename doesn't exist...")
}
}
if (is.logical(saveTPS)){
saveTPS <- checkLogical(saveTPS, 1)
if (saveTPS){
stop("saveTPS should be either FALSE or a string...")
}
overwrite <- NA
append <- NA
} else {
saveTPS <- checkLength(saveTPS, 1)
if (!is.character(saveTPS)) {
stop("saveTPS should be either FALSE or a string...")
}
overwrite <- checkLogical(overwrite,1)
append <- checkLogical(append,1)
}
setwd(curdir)
return(list(sdir = sdir, patt = patt, deci.suffix = deci.suffix, deci.dir = deci.dir,
full.dir = full.dir, full.files = full.files, saveTPS = saveTPS,
overwrite=overwrite , append = append))
}
#' @title Sets Decimation Options
#' @description Set decimation options for \code{\link{digitMesh.character}}.
#' @details This function allows user to set several parameters for mesh decimation needed during the call of
#' \code{\link{digitMesh.character}}. With no arguments, this function returns the default settings for
#' decimation options. Any of those options can be modified by setting new values for the corresponding
#' arguments. Non-filled arguments will be set to default. Ill-filled arguments will return errors or
#' warnings.
#' @usage
#' setDecimOptions(makeDecimation = TRUE, sequential = TRUE,
#' tarface = 15000, patt = ".ply")
#' @param makeDecimation A logical value indicating if the decimation should be performed. \cr
#' Default: \code{TRUE}.
#' @param sequential A logical value indicating if the decimation should be performed mesh by mesh during the landmark
#' digitizing, or in a single pass for all meshes before the digitizing. \cr
#' Default: \code{TRUE} => decimation mesh by mesh during the digitization process.
#' @param tarface A numerical value (positive integer) indicating the targetted number of faces for the decimated
#' meshes. \cr
#' Default: \code{15000}.
#' @param patt A character value taking values within \{\code{".ply"},\code{".stl"}\} indicating the kind of mesh
#' files to treat. \cr
#' Default: \code{".ply"}.
#' @return A list of those parameters.
#' @seealso \code{\link{setFileOptions}}, \code{\link{setGraphicOptions}}, \code{\link{setTemplOptions}}.
#' @export
#' @examples
#' # returning default settings:
#' DeOpt<-setDecimOptions()
#'
#' # setting for non sequential stl decimations:
#' DeOpt<-setDecimOptions(sequential = FALSE, patt = ".stl")
#'
setDecimOptions <- function(makeDecimation = TRUE, sequential = TRUE,
tarface = 15000, patt = ".ply") {
makeDecimation <- checkLogical(makeDecimation, 1)
sequential <- checkLogical(sequential, 1)
tarface <- checkLength(tarface, 1)
if (!is.numeric(tarface)) {
stop("tarface should be a numeric value...")
}
if (tarface < 1) {
stop("tarface should be a positive integer value...")
}
if (round(tarface) != tarface){
stop("tarface should be a positive integer value...")
}
patt <- checkLength(patt, 1)
if (!is.character(patt) | !is.element(tolower(patt), c(".ply", ".stl"))){
stop("Only ply and stl files are supported...")
}
return(list(makeDecimation = makeDecimation, sequential = sequential,
tarface = tarface, patt = patt))
}
#' @title Sets Template Options
#' @description Set options for template during the digitizing process through the call of
#' \code{\link{digitMesh.character}}.
#' @details This function allows user to set several parameters for the use of a template possibly needed during the
#' call of \code{\link{digitMesh.character}}. With no arguments, this function returns the default settings
#' for the template options. Any of those options can be modified by setting new values for the corresponding
#' arguments. Non-filled arguments will be set to default. Ill-filled arguments will return errors or
#' warnings.
#' @usage
#' setTemplOptions(fixed, template = TRUE,
#' idxTemplate = 1:4, full.files = FALSE)
#' @param fixed A numerical value (positive integer) indicating the number of landmarks to digitize.
#' @param template Possible settings: \cr
#' - a logical value (\code{TRUE}: the 1st mesh in the directory will serve as template, \code{FALSE}:
#' no template will be used); \cr
#' - a character value indicating the filename (with extension) of the mesh to use for template; \cr
#' - a numerical \code{fixed*3} matrix containing the template coordinates. \cr
#' Default: \code{TRUE}.
#' @param idxTemplate Numeric vector with positive integers indicating the numbers of landmarks of the template used to
#' fit it on the mesh, sorted in the order with which they will be digitized on the mesh. For
#' example, if the landmarks used are the landmarks numbered 10, 12, 17 and 23, and digitized in the
#' following order on the mesh: 12, 10, 23, 17, \code{idxTemplate} should be set to:
#' \code{c(12, 10, 23, 17)}. \cr
#' Default: \code{1:4} => the first four landmarks will serve as reference landmarks.
#' @param full.files Either a character vector containing the full mesh filenames to treat (in this case the template
#' filename given in the \code{template} argument will be ckecked against the filenames provided in
#' \code{full.files}), or \code{FALSE} (if \code{template} isn't a filename). \cr
#' Default: \code{FALSE}.
#' @return A list with \code{template}, \code{idxTemplate} plus a logical value \code{makeTempl} indicating if a
#' template should be created during the digitization process.
#' @export
#' @examples
#' # returning default settings for 30 landmarks:
#' TeOpt<-setTemplOptions(30)
#'
#' # setting for using a 30*3 coordinate matrix as a template, and for digitizing landmarks {8,14,29,3}
#' # (in this order) to fit th template
#' # 1. generates first a 30*3 random matrix, just for illustration purpose:
#' M <- matrix(rnorm(90), 30, 3)
#' TeOpt<-setTemplOptions(30, template = M, idxTemplate = c(8, 14, 29, 3))
#'
setTemplOptions <- function(fixed, template = TRUE, idxTemplate = 1:4, full.files = FALSE) {
# template & full.files
if(length(template) < 1){
stop("Wrong specification for template argument...")
}
if (!is.character(template)){
if (!is.matrix(template)){
template <- checkLogical(template, 1)
if (template & is.null(full.files)) {
stop("For template=TRUE, full.files argument should be specified...")
} else if(template) {
if (length(full.files) < 1) {
stop("full.files should contain at least one mesh filename...")
}
if (length(full.files) == 1 & is.logical(full.files)) {
if (!full.files) {
template <- template
makeTempl <- template
}
} else {
if (!is.character(full.files)) {
stop("full.files should contain character values...")
}
template <- full.files[1]
makeTempl <- TRUE
}
} else if (!template) {
makeTempl <- FALSE
}
} else {
if(ncol(template) != 3) {
stop("When template is set as a matrix, it should contain 3 columns...")
}
if(nrow(template) < 3) {
stop("When template is set as a matrix, it should contain at least 3 lines...")
}
if (!is.numeric(template)){
stop("When template is set as a matrix, it should contain numerical values...")
}
makeTempl <- FALSE
}
} else {
template <- checkLength(template, 1)
if (!is.logical(full.files)) {
if (!is.element(template, full.files)){
stop("Designed filename mesh for template wasn't found...")
}
makeTempl <- TRUE
} else {
makeTempl <- TRUE
}
}
# fixed
fixed <- checkLength(fixed, 1)
if (!is.numeric(fixed)) {
stop("fixed should be an positive integer value...")
}
if (fixed < 1) {
stop("fixed should be an positive integer value...")
}
if (round(fixed) != fixed) {
stop("fixed should be an positive integer value...")
}
# idxTempalte
if(length(idxTemplate) < 3 | length(idxTemplate) > fixed) {
stop("idxTemplate should contain at least 3 landmarks, and less landmarks than the total number of landmarks...")
}
if (!is.numeric(idxTemplate)) {
stop("idxTemplate should contain positive integer values...")
}
if (min(idxTemplate) < 1 | max(idxTemplate) > fixed) {
stop("idxTemplate should contain positive integer values correponsding to landmark indexes...")
}
if (length(unique(idxTemplate)) != length(idxTemplate)) {
stop("idxTemplate should contain unique values...")
}
if (any(round(idxTemplate) != idxTemplate)) {
stop("idxTemplate should contain integer values...")
}
return(list(template = template, idxTemplate = idxTemplate, makeTempl = makeTempl))
}
Add the following code to your website.
For more information on customizing the embed code, read Embedding Snippets.