Nothing
#' Create and test cmtkreg objects that specify path to a CMTK registration
#'
#' @description \code{cmtkreg} creates an object of class \code{cmtkreg} that
#' describes one (or more) \href{https://www.nitrc.org/projects/cmtk/}{CMTK}
#' registrations. This is simply a character vector that also has class
#' cmtkreg.
#' @param x Path to a cmtk registration (either plain character vector or
#' cmtkreg object)
#' @param returnDir Whether to return the registration directory (default) or
#' the actual file containing the registration
#' @export
cmtkreg<-function(x, returnDir=TRUE){
if(length(x)>1) return(as.cmtkreg(sapply(x,cmtkreg,returnDir=returnDir, USE.NAMES = FALSE)))
x=path.expand(x)
if(!file.exists(x)) {
return(NA_character_)
}
if(file_test("-d", x)){
regdir=x
# this is a directory, so see if we can find the registration
reg=dir(x,pattern="^registration(\\.gz){0,1}",full.names=T)[1]
if(is.na(reg))
stop(paste("Unable to find registration file in",regdir))
} else {
reg=x
regdir=dirname(x)
}
as.cmtkreg(ifelse(returnDir,regdir,reg))
}
#' @description \code{as.cmtkreg} converts objects to class \code{cmtkreg},
#' minimally just by adding an approriate class attribute.
#' @param ... Additional arguments passed to methods. Currently ignored.
#' @rdname cmtkreg
#' @export
as.cmtkreg<-function(x, ...) UseMethod("as.cmtkreg")
#' @rdname cmtkreg
#' @export
as.cmtkreg.matrix <- function(x, ...) {
cmtkreglist(x, ...)
}
#' @rdname cmtkreg
#' @export
as.cmtkreg.reglist <- function(x, ...) {
if(!all(sapply(x, is.character)))
stop("I cannot convert this reglist to a CMTK compatible format")
# cmtkreg expects a character vector
outseq=cmtkreg(unlist(x, use.names = F))
swapped=as.logical(lapply(x, function(x) isTRUE(attr(x,'swap'))))
if(any(swapped)) attr(outseq, 'swap')=swapped
outseq
}
#' @rdname cmtkreg
#' @export
as.cmtkreg.default<-function(x, ...){
if(!inherits(x,'cmtkreg'))
class(x)=c("cmtkreg",class(x))
x
}
#' @description \code{is.cmtkreg} checks if an object is a cmtk registration
#' either by checking class (default), or inspecting file.
#' @param filecheck Whether to check object class only (default: 'none') or find
#' amd check if registration file \strong{exists} or check \strong{magic}
#' value in first line of file.
#' @rdname cmtkreg
#' @export
is.cmtkreg<-function(x, filecheck=c('none','exists','magic')) {
filecheck=match.arg(filecheck, choices = c('none','exists','magic'))
if(filecheck=='none') return(inherits(x,'cmtkreg'))
if(!is.character(x)) return (FALSE)
if(length(x)>1)
return(sapply(x, is.cmtkreg, filecheck=filecheck))
reg=try(cmtkreg(x, returnDir=FALSE), silent=TRUE)
if(inherits(reg, 'try-error') || is.na(reg)) {
return(FALSE)
} else if(filecheck=='exists') return(TRUE)
# charToRaw('! TYPEDSTREAM')
cmtk.magic=as.raw(c(0x21, 0x20, 0x54, 0x59, 0x50, 0x45, 0x44, 0x53, 0x54,
0x52, 0x45, 0x41, 0x4d))
magic=try({
gzf<-gzfile(reg,'rb')
magic<-readBin(gzf,what=raw(),n=length(cmtk.magic))
close(gzf)
magic},
silent = TRUE)
return(!inherits(magic,'try-error') &&
length(magic)==length(cmtk.magic)
&& all(magic==cmtk.magic))
}
#' Plot the domain of a CMTK registration
#'
#' @param x A cmtk registration (the path to the registration folder on disk) or
#' the resulting of reading one in with \code{\link{read.cmtkreg}}.
#' @param ... Additional arguments passed to \code{\link[rgl]{plot3d}}
#' @seealso \code{\link{cmtkreg}}, \code{\link{read.cmtkreg}},
#' \code{\link[rgl]{plot3d}}
#' @examples
#' \dontrun{
#' testdatadir=system.file("tests/testthat/testdata/cmtk", package="nat")
#' regpath=file.path(testdatadir,'FCWB_JFRC2_01_warp_level-01.list/')
#' plot3d(cmtkreg(regpath))
#'
#' # or read registration into memory if you want to work with it
#' reg=read.cmtkreg(regpath)
#' # nb calling plot3d.cmtkreg directly (rather than using the generic plot3d)
#' # is considered bad style but read.cmtkreg returns a plain list
#' # so method dispatch will fail
#' nat:::plot3d.cmtkreg(reg)
#' }
#' @importFrom rgl plot3d
#' @export
plot3d.cmtkreg <- function(x, ...) {
reg=NULL
if(is.list(x)) {
if(!is.null(x$registration)) reg=x$registration else reg=x
if(is.null(reg$spline_warp))
stop("This looks like an in memory CMTK registration but I can't find the spline_warp field")
} else if(is.character(x)) {
reg <- read.cmtkreg(x, ReturnRegistrationOnly = TRUE)
} else stop("Don't know what to do with this input!")
coeffs=reg$spline_warp$coefficients
aidxs=seq.int(from=1, by=3L, length.out = nrow(coeffs))
actives=reg$spline_warp$active[aidxs]!=0
plot3d(coeffs[actives, ], xlab='X', ylab = "Y", zlab = "Z", ...)
}
Any scripts or data that you put into this service are public.
Add the following code to your website.
For more information on customizing the embed code, read Embedding Snippets.