### Todo : most of it will move to Momit/Momacs
# txt -----------------------
#' Import coordinates from a .txt file
#'
#' A wrapper around \link{read.table}
#' that can be used to import outline/landmark coordinates.
#'
#' Columns are not named in the \code{.txt} files. You can tune this using the \code{...} argument.
#' Define the \link{read.table} arguments that allow to import a single file, and then
#' pass them to this function, ie if your \code{.txt} file
#' has a header (eg ('x', 'y')), do not forget \code{header=TRUE}.
#' @param txt.paths a vector of paths corresponding to the .txt files to import. If not
#' provided (or \code{NULL}), switches to the automatic version, just as in \link{import_jpg}.
#' See Details there.
#' @param ... arguments to be passed to \link{read.table}, eg. 'skip', 'dec', etc.
#'
#' @note Note this function will be deprecated from Momocs
#' when \code{Momacs} and \code{Momit}
#' will be fully operationnal.
#'
#' @note Silent message and progress bars (if any) with `options("verbose"=FALSE)`.
#' @return a list of matrix(ces) of (x; y) coordinates that can be passed to
#' \link{Out}, \link{Opn} and \link{Ldk}.
#' @family import functions
#' @export
import_txt <- function(txt.paths = .lf.auto(), ...) {
# if (is.null(txt.paths)) {
# txt.paths <- .lf.auto()
# }
if (.is_verbose())
cat(" * Extracting ", length(txt.paths), "..txt coordinates...\n")
if (length(txt.paths) > 10 & .is_verbose()) {
pb <- progress::progress_bar$new(total = length(txt.paths))
t <- TRUE
} else {
t <- FALSE
}
res <- list()
for (i in seq(along = txt.paths)) {
coo <- utils::read.table(txt.paths[i], ...)
res[[i]] <- as.matrix(coo)
if (t)
pb$tick()
}
# names(res) <- substr(txt.paths, start=1,
# stop=nchar(txt.paths)-4)
names(res) <- txt.paths %>% .trim.ext() %>% .trim.path()
return(res)
}
# outlines ------------------
#' Extract outlines coordinates from an image silhouette
#'
#' Provided with an image 'mask' (i.e. black pixels on a white background),
#' and a point form where to start the algorithm, returns the (x; y) coordinates of its outline.
#'
#' Used internally by \link{import_jpg1} but may be useful for other purposes.
#' @param img a matrix of a binary image mask.
#' @param x numeric the (x; y) coordinates of a starting point within the shape.
#' @return a matrix the (x; y) coordinates of the outline points.
#'
#' @note Note this function will be deprecated from Momocs
#' when \code{Momacs} and \code{Momit}
#' will be fully operationnal.
#'
#' @references
#' \itemize{
#' \item The original algorithm is due to: Pavlidis, T. (1982). \emph{Algorithms
#' for graphics and image processing}. Computer science press.
#' \item is detailed in: Rohlf, F. J. (1990). An overview of image processing and
#' analysis techniques for morphometrics. In \emph{Proceedings of the Michigan Morphometrics Workshop}. Special Publication No. 2 (pp. 47-60). University of Michigan Museum of Zoology: Ann Arbor.
#' \item and translated in R by: Claude, J. (2008). \emph{Morphometrics with R}. (p. 316). Springer.
#' }
#'
#' @note If you have an image with more than a single shape, then
#' you may want to try `imager::highlight` function. Momocs may use this at some point.
#' @family import functions
#' @export
import_Conte <- function(img, x) {
while (abs(img[x[1], x[2]] - img[x[1] - 1, x[2]]) < 0.1) {
x[1] <- x[1] + 1
}
# while (abs(img[x[1], x[2]] - img[x[1], x[2]-1]) < 0.1) {
# x[2] <- x[2] -1 }
a <- 1
M <- matrix(c(0, -1, -1, -1, 0, 1, 1, 1, 1, 1, 0, -1, -1,
-1, 0, 1), nrow = 2, ncol = 8, byrow = TRUE)
M <- cbind(M[, 8], M, M[, 1])
X <- 0
Y <- 0
x1 <- x[1]
x2 <- x[2]
SS <- NA
S <- 6
while ((any(c(X[a], Y[a]) != c(x1, x2)) | length(X) < 3)) {
if (abs(img[x[1] + M[1, S + 1], x[2] + M[2, S + 1]] -
img[x[1], x[2]]) < 0.1) {
a <- a + 1
X[a] <- x[1]
Y[a] <- x[2]
x <- x + M[, S + 1]
SS[a] <- S + 1
S <- (S + 7)%%8
} else if (abs(img[x[1] + M[1, S + 2], x[2] + M[2, S +
2]] - img[x[1], x[2]]) < 0.1) {
a <- a + 1
X[a] <- x[1]
Y[a] <- x[2]
x <- x + M[, S + 2]
SS[a] <- S + 2
S <- (S + 7)%%8
} else if (abs(img[x[1] + M[1, S + 3], x[2] + M[2, S +
3]] - img[x[1], x[2]]) < 0.1) {
a <- a + 1
X[a] <- x[1]
Y[a] <- x[2]
x <- x + M[, S + 3]
SS[a] <- S + 3
S <- (S + 7)%%8
} else {
S <- (S + 1)%%8
}
}
return(cbind((Y[-1]), ((dim(img)[1] - X))[-1]))
}
#' Extract outline coordinates from a single .jpg file
#'
#' Used to import outline coordinates from .jpg files. This function is used for
#' single images and is wrapped by \link{import_jpg}. It relies itself on \link{import_Conte}
#' @param jpg.path vector of paths corresponding to the .jpg files to import, such as
#' those obtained with \link{list.files}.
#' @param auto.notcentered logical if TRUE random locations will be used until
#' one of them is (assumed) to be within the shape (because it corresponds to a black pixel) and only if
#' the middle point is not black;
#' if FALSE a \link{locator} will be called, and you will have to click on a
#' point within the shape.
#' @param fun.notcentered NULL by default but can accept a function that, when passed with an imagematrix and returns
#' a numeric of length two that corresponds to a starting point on the imagematrix for the Conte
#' algorithm. A \code{while} instruction wraps it, so the function may be wrong in proposing this
#' starting position. See the examples below for a quick example.
#' @param threshold the threshold value use to binarize the images. Above, pixels
#' are turned to 1, below to 0.
#' @param ... arguments to be passed to \link{read.table}, eg. 'skip', 'dec', etc.
#'
#' @note Note this function will be deprecated from Momocs
#' when \code{Momacs} and \code{Momit}
#' will be fully operationnal.
#'
#'
#' @details jpegs can be provided either as RVB or as 8-bit greylevels or monochrome.
#' The function binarizes pixels values using the 'threshold' argument. It will try to start to
#' apply the \link{import_Conte} algorithm from the center of
#' the image and 'looking' downwards for the first black/white 'frontier' in
#' the pixels. This point will be the first of the outlines. The latter may be useful
#' if you align manually the images and if you want to retain this information
#' in the consequent morphometric analyses.
#'
#' If the point at the center of the
#' image is not within the shape, i.e. is 'white' you have two choices defined by
#' the 'auto.notcentered' argument. If it's TRUE, some random starting points
#' will be tried until on of them is 'black' and within the shape; if FALSE
#' you will be asked to click on a point within the shape.
#'
#' If some pixels on the borders are not white, this functions adds a 2-pixel
#' border of white pixels; otherwise \link{import_Conte} would fail and return an error.
#'
#' Finally, remember that if the images are not in your working directory,
#' \link{list.files} must be called with the argument \code{full.names=TRUE}!
#'
#' Note that the use of the \code{fun.notcentered} argument will probably leads to serious headaches
#' and will probably imply the dissection of these functions: \link{import_Conte}, \link{img_plot} and
#' \code{import_jpg} itself
#' @seealso \link{import_jpg}, \link{import_Conte}, \link{import_txt}, \link{lf_structure}.
#' See also Momocs' vignettes for data import.
#' @return a matrix of (x; y) coordinates that can be passed to Out
#' @family import functions
#' @export
import_jpg1 <- function(jpg.path,
auto.notcentered = TRUE,
fun.notcentered = NULL,
threshold = 0.5, ...) {
img <- jpeg::readJPEG(jpg.path)
# if a RVB is provided by the way, apply (img, 1:2, mean) is
# much slower
if (!is.matrix(img)) {
img <- (img[, , 1] + img[, , 2] + img[, , 3])/3
}
# we binarize using threshold
img[img > threshold] <- 1
img[img <= threshold] <- 0
# we test for images with black pixels on their border which
# causes Conte to fail. IF it is the case, we add a 1 pixel
# white border around
borders <- c(img[1, ], img[nrow(img), ], img[, 1], img[,
ncol(img)])
if (any(borders != 1)) {
.mat.buffer <- function(m, buff.size, buff.fill = 1) {
nr <- nrow(m)
c.buff <- matrix(buff.fill, nrow = nr, ncol = buff.size)
m <- cbind(c.buff, m, c.buff)
nc <- ncol(m)
r.buff <- matrix(buff.fill, nrow = buff.size, ncol = nc)
m <- rbind(r.buff, m, r.buff)
return(m)
}
img <- .mat.buffer(img, buff.size = 2, buff.fill = 1)
}
# img <- x[dim(x)[1]:1,] #Conte/readJPEG, etc. we initialize
# value with the middle or (1,1)
if (is.null(fun.notcentered)) {
x <- round(dim(img)/2)
} else {
x <- c(1, 1)
}
# while we dont start a black pixel (ie img[x1, x2]==0) to
# start Conte, we search for it k is the number of tries
# tries_max <- 50 tries <- 1 while (img[x[1], x[2]] != 0 &
# tries < tries_max) {
while (img[x[1], x[2]] != 0) {
# etiher with a smart function, if provided
if (!is.null(fun.notcentered)) {
x <- fun.notcentered(img)
}
# either randomly picking points
if (auto.notcentered) {
while (img[x[1], x[2]] != 0) {
x[1] <- sample(dim(img)[1], 1)
x[2] <- sample(dim(img)[2], 1)
}
}
# or manually by plotting the image and begging for a click
if (is.null(fun.notcentered) & !auto.notcentered) {
img_plot(img)
while (img[x[1], x[2]] != 0) {
message("Click a point within the shape")
xy <- unlist(locator(1))
x <- round(c(nrow(img) - xy[2], xy[1]))
if (x[1] > dim(img)[1]) {
x[1] <- dim(img)[1]
}
if (x[1] < 1) {
x[1] <- 1
}
if (x[2] > dim(img)[2]) {
x[2] <- dim(img)[2]
}
if (x[2] < 1) {
x[2] <- 1
}
}
# cat(xy, '\t', x, '\n') here, for tests
}
# tries <- tries + 1 cat(tries)
}
# if (tries >= tries_max) { return(NA) } Then we start
# import_Conte
out <- import_Conte(img, x)
return(out)
}
#' Extract outline coordinates from multiple .jpg files
#'
#' This function is used to import outline coordinates and is built around
#' \link{import_jpg1}.
#' @param jpg.paths a vector of paths corresponding to the .jpg files to import. If not
#' provided (or \code{NULL}), switches to the automatic version. See Details below.
#' @param auto.notcentered logical if TRUE random locations will be used until.
#' one of them is (assumed) to be within the shape (because of a black pixel);
#' if FALSE a \link{locator} will be called, and you will have to click on a
#' point within the shape.
#' @param fun.notcentered NULL by default. Is your shapes are not centered and if a random pick of
#' a black pixel is not satisfactory. See \link{import_jpg1} help and examples.
#' @param threshold the threshold value use to binarize the images. Above, pixels
#' are turned to 1, below to 0.
#'
#' @note Note this function will be deprecated from Momocs
#' when \code{Momacs} and \code{Momit}
#' will be fully operationnal.
#'
#' @note Silent message and progress bars (if any) with `options("verbose"=FALSE)`.
#'
#' @details see \link{import_jpg1} for important informations about how the outlines are extracted,
#' and \link{import_Conte} for the algorithm itself.
#'
#' If \code{jpg.paths} is not provided (or \code{NULL}), you will have to select any \code{.jpg}
#' file in the folder that contains all your files. All the outlines should be imported then.
#' @return a list of matrices of (x; y) coordinates that can be passed to \link{Out}
#' @examples
#' \donttest{
#'
# # if your images are in the folder '/foo/jpgs/'
#' lf <- list.files('/foo/jpegs', full.names=TRUE)
#' coo <- import_jpg(lf)
#' Out(coo)
#'
# # 'automatic' version
#' coo <- import_jpg()
#' }
#' @family import functions
#' @export
import_jpg <- function(jpg.paths = .lf.auto(), auto.notcentered = TRUE,
fun.notcentered = NULL, threshold = 0.5) {
# if not provided
# if (is.null(jpg.paths)) {
# jpg.paths <- .lf.auto()
# }
begin <- Sys.time()
message("Extracting ", length(jpg.paths), ".jpg outlines...")
if (length(jpg.paths) > 10 & .is_verbose()) {
pb <- progress::progress_bar$new(total = length(jpg.paths))
t <- TRUE
} else {
t <- FALSE
}
# for a futurer safer import jpg.names <-
# .trim.path(.trim.ext(jpgs.paths))
res <- list()
n <- length(jpg.paths)
for (i in seq(along = jpg.paths)) {
if (.is_verbose()) {
cat("[", i, "/", n, "] ", .trim.path(jpg.paths[i]))
}
coo_i <- import_jpg1(jpg.paths[i], auto.notcentered = auto.notcentered,
fun.notcentered = fun.notcentered, threshold = threshold)
res[[i]] <- coo_i
# if (export){coo_export(coo_i, jpg.paths[i])}
if (.is_verbose()) {
cat("\n")
} else {
if (t)
pb$tick()
}
}
names(res) <- jpg.paths %>% .trim.ext() %>% .trim.path()
if (.is_verbose()) {
end <- Sys.time()
time <- end - begin
message("Done in ", round(as.numeric(time), 1), " ", units(time))
}
return(res)
}
# StereoMorph ---------------
#' Import files creates by StereoMorph into Momocs
#'
#' Helps to read \code{.txt} files created by StereoMorph into (x; y) coordinates
#' or Momocs objects. Can be applied to 'curves' or 'ldk' text files.
#' @param path toward a single file or a folder containing \code{.txt} files produced by StereoMorph
#' @param names to feed \link{lf_structure}
#'
#' @note Note this function will be deprecated from Momocs
#' when \code{Momacs} and \code{Momit}
#' will be fully operationnal.
#'
#'
#' @details *1 functions import a single \code{.txt} file. Their counterpart (no '1')
#' work when path indicates the folder, i.e. 'curves' or 'ldk'. They then return a list
#' of \link{Opn} or \link{Ldk} objects, respectively. Please do not hesitate to contact me
#' should you have a particular case or need something.
#' @rdname import_StereoMorph
#' @return a list of class Coo
#' @family import functions
#' @export
import_StereoMorph_curve1 <- function(path){
# tem fix
stop("deprecated due to major update in StereoMorph export file format. You can try the solution by Stas Malavin before this being fixed in Momocs: https://github.com/stas-malavin/Momocs/blob/master/R/importSM.r")
# we split the loci contained in the first column
df <- utils::read.table(path, header=FALSE, stringsAsFactors = FALSE) %>%
select(locus=1, x=2, y=3) %>%
mutate(name=substr(locus, 1, nchar(locus)-4)) %>%
select(name, x, y)
return(split(df[, c("x", "y")], as.factor(df$name)))
}
#' @rdname import_StereoMorph
#' @family import functions
#' @export
import_StereoMorph_curve <- function(path, names){
# tem fix
stop("deprecated due to major update in StereoMorph export file format. You can try the solution by Stas Malavin before this being fixed in Momocs: https://github.com/stas-malavin/Momocs/blob/master/R/importSM.r")
# we extract filenames and import them
lf <- list.files(path, full.names=TRUE)
res <- lapply(lf, import_StereoMorph_curve1)
names(res) <- lf %>% .trim.ext() %>% .trim.path()
# so that we have a list of loci that include filenames that we turn into Opns
res <- .rollup_list(res)
res <- lapply(res, Opn)
# if names are provided we apply them
if (!missing(names)) {
for (i in seq_along(res))
res[[i]]$fac <- lf_structure(names(res[[i]]), names)
}
return(res)
}
#' @rdname import_StereoMorph
#' @family import functions
#' @export
import_StereoMorph_ldk1 <- function(path){
# tem fix
stop("deprecated due to major update in StereoMorph export file format. You can try the solution by Stas Malavin before this being fixed in Momocs: https://github.com/stas-malavin/Momocs/blob/master/R/importSM.r")
# a cousin of import_txt
utils::read.table(path, header=FALSE,
row.names=1, col.names=c("l", "x", "y"), stringsAsFactors = FALSE)
}
#' @rdname import_StereoMorph
#' @family import functions
#' @export
import_StereoMorph_ldk <- function(path, names){
# tem fix
stop("deprecated due to major update in StereoMorph export file format. You can try the solution by Stas Malavin before this being fixed in Momocs: https://github.com/stas-malavin/Momocs/blob/master/R/importSM.r")
# we extract filenames and import them
lf <- list.files(path, full.names=TRUE)
res <- lapply(lf, import_StereoMorph_ldk1)
names(res) <- lf %>% .trim.ext() %>% .trim.path()
# so that we have a list of loci that include filenames that we turn into Opns
res <- Ldk(res)
# if names are provided we apply them
if (!missing(names)) {
res$fac <- lf_structure(names(res), names)
}
return(res)
}
# tps -----------------------
#' Import a tps file
#'
#' And returns a list of coordinates, curves, scale
#' @param tps.path lines, typically from \link{readLines}, describing a single shape in tps-like format.
#' You will need to manually build your \code{Coo} object from it: eg \code{Out(coo=your_list$coo)}.
#' @param curves \code{logical} whether to read curves, if any
#' @param tps lines for a single tps file
#' \code{tps2coo} is used in \link{import_tps} and may be useful for data import. When provided
#' with lines (eg after \link{readLines}) from a tps-like description (with "LM", "CURVES", etc.) returns a list of
#' coordinates, curves, etc.
#'
#' @note Note this function will be deprecated from Momocs
#' when \code{Momacs} and \code{Momit}
#' will be fully operationnal.
#'
#' @return a list with components:
#' \code{coo} a matrix of coordinates; \code{cur} a list of matrices; \code{scale} the scale as a numeric.
#' @rdname import_tps
#' @family import functions
#' @export
import_tps <- function(tps.path, curves=TRUE){
# we import the tps, line by line
tps <- readLines(tps.path)
# we remove empty lines, if any
tps <- tps[nchar(tps) != 0]
# we detect the position of 'LM'
LM.pos <- grep("LM", tps)
# we extract shape names, if IMAGE is present, use it; else ID, else we create them
if (length(grep("IMAGE", tps))>0){
shp.names <- .trim.ext(gsub("IMAGE=", "", grep("IMAGE", tps, value=TRUE)))
} else {
if(length(grep("ID", tps))>0){
shp.names <- gsub("ID=", "", grep("ID", tps, value=TRUE))
} else {
shp.names <- paste0("id", 1:length(LM.pos))
}
}
# we prepare the blocks of shapes
shp.pos <- data.frame(start = LM.pos, end = c(LM.pos[-1]-1, length(tps)))
res <- vector("list", nrow(shp.pos))
for (i in seq_along(res)){
res[[i]] <- tps[shp.pos$start[i]:shp.pos$end[i]] %>% tps2coo(curves=curves)
}
names(res) <- shp.names
# if only landmarks, we return a list of matrices
classes <- sapply(res, class) %>% unique()
if (!curves)
return(res)
# curves=FALSE case
# also we check a bit for case where curves=TRUE but some curves are missing
classes <- sapply(res, class)
# in such a case, lists are expected to be returned by tps2coo
if (any(classes!="list")){
stop("these shapes do not have curves:", shp.names[which(classes != "list")])
}
return(.rollup_list(res))
}
#' @rdname import_tps
#' @family import functions
#' @export
tps2coo <- function(tps, curves=TRUE){
scale <- NULL
cur <- NULL
# we read the nb of landmarks
# some tps files (for outlines?) have a special
# format with no LM= but POINTS=
gPOINTS <- grep("POINTS=", tps)
if (length(gPOINTS)>0){
coo.nb <- tps[gPOINTS] %>% gsub("POINTS=", "", .) %>% as.numeric()
} else {
coo.nb <- as.numeric(gsub("LM=", "", tps[1]))
}
# we read "SCALE=", if any
scale <- as.numeric(gsub("SCALE=", "", grep("SCALE=", tps, value=TRUE)))
# removes the first line "LM=" and, if any, "IMAGE=", "ID=" and "SCALE=" lines
rm.ids <- c(1, grep("IMAGE|ID|SCALE|OUTLINES|POINTS", tps))
tps <- tps[-rm.ids]
# this function turns lines of coordinates into a shp
lines2shp <- function(l) {
l %>% strsplit(" ") %>% unlist() %>%
as.numeric() %>%
matrix(nrow=length(l), byrow=TRUE)
}
# here we extract coos and check a bit
coo <- tps[1:coo.nb] %>% lines2shp()
.check(nrow(coo)==coo.nb,
"the number of landmarks seems to differ from LM=")
# no curve case
if (!curves)
return(list(coo=coo, cur=cur, scale=scale))
# curve case
# we check that curves are really present, if not we return coo
if (length(grep("CURVE", tps))==0)
return(list(coo=coo, cur=cur, scale=scale))
# we get rid of landmarks and "CURVES" lines
tps <- tps[-c(1:coo.nb, coo.nb+1)]
# we extract POINTS ids and deduce curves ids
cur.start <- grep("POINTS", tps)+1
cur.end <- c(cur.start[-1]-2, length(tps))
# we create a list to store curves coordinates
cur <- vector("list", length(cur.start))
for (i in seq_along(cur.start)){
cur[[i]] <- tps[cur.start[i]:cur.end[i]] %>% lines2shp
}
return(list(coo=coo, cur=cur, scale=scale))
}
# other formats -------------
#' Convert (x; y) coordinates to chaincoded coordinates
#'
#' Useful to convert (x; y) coordinates to chain-coded coordinates.
#' @param coo (x; y) coordinates passed as a matrix
#' @param chc chain coordinates
#' @seealso \link{chc2pix}
#'
#' @note Note this function will be deprecated from Momocs
#' when \code{Momacs} and \code{Momit}
#' will be fully operationnal.
#'
#' @references Kuhl, F. P., & Giardina, C. R. (1982).
#' Elliptic Fourier features of a closed contour.
#' \emph{Computer Graphics and Image Processing}, 18(3), 236-258.
#' @return a matrix or a numeric
#' @examples
#' pix2chc(shapes[1]) %T>% print %>% # from pix to chc
#' chc2pix() # and back
#' @rdname babel
#' @family import functions
#' @export
pix2chc <- function(coo) {
if (is.list(coo)) {
coo <- l2m(coo)
}
if (is.matrix(coo) & ncol(coo) != 2) {
stop("a 2-col matrix must be provided")
}
coo_d <- apply(coo, 2, diff)
if (!all(coo_d %in% -1:1)) {
stop("matrix must contain only entire pixels indices")
}
if (any(apply(coo_d, 1, function(x) all(x == rep(0, 2))))) {
stop("at least two successive coordinates do not code for a displacement")
}
m <- as.matrix(expand.grid(-1:1, -1:1))[-5, ]
g <- c(5, 6, 7, 4, 0, 3, 2, 1)
chc <- g[apply(coo_d, 1, function(x) which(x[1] == m[, 1] &
x[2] == m[, 2]))] #dirty
return(chc)
}
#' @rdname babel
#' @family import functions
#' @export
chc2pix <- function(chc) {
if (!all(chc %in% 0:7)) {
stop("chc string must only contain integers between 0 and 7")
}
m <- matrix(c(1, 0, 1, 1, 0, 1, -1, 1, -1, 0, -1, -1, 0,
-1, 1, -1), ncol = 2, byrow = TRUE)
pix <- apply(m[chc + 1, ], 2, cumsum)
return(pix)
}
# #' Converts chain-coded coordinates to Out object
# #'
# #' For Shape/ChainCoder files, a wrapper to convert chain-coded coordinates to
# #' \code{\link{Out}} objects.
# #' @param chc a path to the chc file
# #' @param skip numeric how many informations before the first chain-coded information
# #' @param names an (optional) vector of (skip) names for the \code{fac} created.
# #' Somehow similar to \code{names} in \link{lf_structure}
# #'
# #' @note Note this function will be deprecated from Momocs
# #' when \code{Momacs} and \code{Momit}
# #' will be fully operationnal.
# #'
# #' @details
# #' Files from Shape/ChainCoder comes this way:
# #' \preformatted{
# #' Name_1 fac1 fac2 fac3 [...] 6 6 6 6 6 6 6 6 7 6 [...] -1
# #' Name_2 fac1 fac2 fac3 [...] 6 6 6 6 5 5 7 6 7 6 [...] -1
# #' }
# #' This function does the following:
# #' \enumerate{
# #' \item take everything before the first chain-coded
# #' coordinate (here a "6") and transform it into a \code{data.frame}, later used
# #' as a \code{fac}
# #' \item convert all the chain-coded coordinates into (x; y) coordinates
# #' using \link{chc2pix}
# #' (and removes) the "-1" that mark the end of coordinates
# #' \item returns an \code{\link{Out}} object with the corresponding \code{fac}
# #' and with outlines named after the first \code{fac} column
# #' (here with Name_1, Name_2, etc.)
# #' }
# #' This function needs to know how many information (space-separated there is
# #' before) the first coordinate. On the example above, would be 4 id [...] was empty.
# #'
# #' @note Note this function will be deprecated from Momocs
# #' when \code{Momacs} and \code{Momit}
# #' will be fully operationnal.
# #'
# #' @seealso \link{pix2chc}
# #' @references Kuhl, F. P., & Giardina, C. R. (1982).
# #' Elliptic Fourier features of a closed contour.
# #' \emph{Computer Graphics and Image Processing}, 18(3), 236-258.
# #' @examples
# #' \dontrun{
# #' # if the file above was called 'coded.chc' in the 'data' folder:
# #' chc2Out("data/coded.chc", skip=4)
# #' }
# #' @family babel functions
# #' @export
# #' chc2Out <- function(chc, skip, names){
# #' # read the file and break spaces
# #' chc <- readLines(chc)
# #' chc <- strsplit(chc, " ")
# #' # retrieve the first columns and create a fac
# #' df <- sapply(chc, function(x) x[1:skip])
# #' fac <- data.frame(t(df))
# #' # nice fac names
# #' if (!missing(names)){
# #' if (length(names)!=skip) {
# #' cat(" * names and skip length differ\n")
# #' names <- paste0("col", 1:skip)
# #' }
# #' } else {
# #' names <- paste0("col", 1:skip)
# #' }
# #' colnames(fac) <- names
# #' # remove these columns from the chc
# #' chc <- lapply(chc, function(x) x[-(1:skip)])
# #' # loop over the list: remove the (last) -1, pass it to chc2pix
# #' coo <- lapply(chc, function(x) chc2pix(as.numeric(x[-length(x)])))
# #' # prepare and return an Out
# #' names(coo) <- fac[, 1]
# #' Out(coo, fac=fac)}
# #'
# #' Imports .nef to Coe objects
# #'
# #' Useful to convert .nef files into Coe objects.
# #' It returns a matrix of coefficients that can be passed to \link{Coe}.
# #' @param nef.path the path to the .nef file
# #' @note nef2Coe cannot really deduces some components of the \code{OutCoe} constructor.
# #' Most of the time working around \code{x <- nef2Coe(); OutCoe(x, method="efourier", norm=TRUE/FALSE)}
# #' shoudl do the job. Overall, I'm not very familiar to other morphometric formats.
# #' So if you have troubles importing your datasets, contact me, I can help. Or if you fix something,
# #' please let met know!
# #'
# #' Note this function will be deprecated from Momocs
# #' when \code{Momacs} and \code{Momit}
# #' will be fully operationnal.
# #'
# #' @family babel functions
# #' @examples
# #' # nef2Coe cannot really deduces some components of the
# #' @export
# nef2Coe <- function(nef.path) {
# # change nef to coe one day
# nef <- readLines(nef.path)
# HARMO.l <- grep(pattern = "HARMO", nef)
# nb.h <- as.numeric(substring(nef[HARMO.l], 8))
# nef <- nef[-(1:HARMO.l)]
# nb.coo <- length(nef)/(nb.h + 1)
# coo_i <- 1:nb.coo
# coo_beg <- (coo_i - 1) * (nb.h + 1) + 1
# coo_end <- coo_beg + nb.h
# res <- matrix(NA, nrow = nb.coo, ncol = nb.h * 4, dimnames = list(nef[coo_beg],
# paste0(rep(LETTERS[1:4], each = nb.h), 1:nb.h)))
# reorder <- c(1:nb.h * 4 - 3, 1:nb.h * 4 - 2, 1:nb.h * 4 -
# 1, 1:nb.h * 4)
# for (i in seq(along = coo_i)) {
# nef.i <- nef[(coo_beg[i] + 1):coo_end[i]]
# x <- as.numeric(unlist(strsplit(nef.i, " ")))
# x <- x[!is.na(x)]
# res[i, ] <- x[reorder]
# }
# return(res)
# }
# deprecated see import_tps
# #' From .tps to Coo objects
# #'
# #' Useful to convert .tps files into Coo objects.
# #' It returns a list of matrices of coordinates that can be passed to \link{Coo} (\link{Out}, \link{Opn} or \link{Ldk}).
# #' @param tps.path the path to the .tps file
# #' @param sep the separator between data
# #' @note I'm not very familiar to other morphometric formats.
# #' So if you have troubles importing your datasets, contact me, I can help. Or if you fix something,
# #' please let met know!
# #' @family babel functions
# #' @export
# tps2Coo <- function(tps.path, sep = " ") {
# # we read all lines of the file
# tps <- readLines(tps.path)
# # we detect the beginning of every individual
# tps_pos <- cbind(grep(pattern = "lm=", x = tps, ignore.case = TRUE),
# c(grep(pattern = "lm=", x = tps, ignore.case = TRUE)[-1] -
# 1, length(tps)))
# # we prepare a vector and a list to host the data
# img.names <- character()
# coo_list <- list()
# # and we loop over individuals
# for (i in 1:nrow(tps_pos)) {
# # first we pick one of the individuals
# tps_i <- tps[tps_pos[i, 1]:tps_pos[i, 2]]
# # and we grab and clean the image name information
# img.i <- tps_i[grep("image", tps_i, ignore.case = TRUE)]
# img.i <- gsub("image=", "", img.i, ignore.case = TRUE)
# img.names[i] <- gsub(".jpg", "", img.i, ignore.case = TRUE)
# # here we exclude every line that start with a letter
# coo_i <- tps_i[-grep(pattern = "[[:alpha:]]", tps_i)]
# # and convert it as a matrix of coordinates
# coo_i <- unlist(strsplit(coo_i, sep))
# coo_list[[i]] <- matrix(as.numeric(coo_i), ncol = 2,
# byrow = TRUE)
# }
# coo_list <- lapply(coo_list, function(x) colnames())
# names(coo_list) <- img.names
# return(coo_list)
# }
# #' Imports .nts to Coo objects
# #'
# #' Useful to convert .nts files into \link{Coo} objects. For .nts provided as rows, use
# #' ntsrow2Coo; for .nts provided as columns of coordinates, try ntscol2Coo. It
# #' returns a list of matrices of coordinates that can be passed to \link{Coo} (\link{Out}, \link{Opn} or \link{Ldk}).
# #' @aliases ntscol2Coo ntsrow2Coo
# #' @param nts.path the path to the .nts file
# #' @param sep the separator between data
# #'
# #' @note Note this function will be deprecated from Momocs
# #' when \code{Momacs} and \code{Momit}
# #' will be fully operationnal.
# #'
# #' @examples
# #' # That's how wings dataset was created
# #' # made a local copy from http://life.bio.sunysb.edu/morph/data/RohlfSlice1990Mosq.nts
# #' # then :
# #' # coo_list <- ntscol2Coo('~/Desktop/mosquitowings.nts)
# #' # fac <- data.frame(fac=factor(substr(names(coo_list), 1, 2)))
# #' # wings <- Ldk(coo_list, fac=fac)
# #' @family babel functions
# #' @export
# ntsrow2Coo <- function(nts.path, sep = "\t") {
# # we read all lines and remove the first one
# nts <- readLines(nts.path, warn = FALSE)
# comments <- grep(pattern = "\"", nts)
# nts <- nts[-comments]
# # we prepare a vector and a list to store the data
# img.i <- character()
# coo_list <- list()
# # we loop over every individual
# for (i in 1:length(nts)) {
# # we pick every individual
# ind.i <- unlist(strsplit(nts[i], sep))
# # the first element is the name
# img.i[i] <- ind.i[1]
# # then we convert the rest as a matrix
# coo_list[[i]] <- matrix(as.numeric(ind.i[-1]), ncol = 2,
# byrow = TRUE)
# }
# # we rename list components with image names
# names(coo_list) <- img.i
# return(coo_list)
# }
#
# #' @export
# ntscol2Coo <- function(nts.path, sep = "\t") {
# # candidate for the most ugly function ever? we read all
# # lines and remove the skip one
# nts <- readLines(nts.path, warn = FALSE)
# comments <- grep(pattern = "\"", nts)
# nts <- nts[-comments]
# nb.ldk <- as.numeric(strsplit(nts[1], " ")[[1]][3])
# nts <- nts[-1]
# nts <- unlist(strsplit(nts, " "))
# nts <- nts[-which(nchar(nts) == 0)]
# nb.nts <- length(nts)/(nb.ldk + 1)
# # we prepare a vector and a list to store the data
# names.id <- 1 + (nb.ldk + 1) * (0:(nb.nts - 1))
# start.id <- names.id + 1
# end.id <- start.id + nb.ldk - 1
# img.i <- nts[names.id]
# coo_list <- list()
# # we loop over every individual
# for (i in 1:nb.nts) {
# coo_list[[i]] <- matrix(as.numeric(nts[start.id[i]:end.id[i]]),
# ncol = 2, byrow = TRUE)
# }
# # we rename list components with image names
# names(coo_list) <- img.i
# return(coo_list)
# }
# bind_db
# TODO: implement a proper join method
# #' Binds with a database
# #'
# #' Adds columns to a \link{Coo} or \link{Coe} object from a data base. Data base must
# #' be provided as a data.frame or as a path which will be \link{read.table}d with \code{...}
# #' arguments.
# #'
# #' Many checks are done on the binding and this is the main advantage of using this method.
# #' It requires an "id" on both the Coo/Coe and the database. There is no assumption
# #' that shapes/coefficients are in the right order in the Coo/Coe
# #' (but a mutate(your_object, id=1:length(your_object)) would do the trick, see examples).
# #'
# #' @param x Coo or Coe object
# #' @param fac_col \code{character} (no numeric here) where to find ids in the fac
# #' @param db \code{data.frame} with the right number of rows, or a path as \code{character}. Then use ... to pass arguments to \link{read.table}
# #' @param db_col \code{character} where to fin ids in db
# #' @param ... more parameters passed to \link{read.table}
# #' @family babel functions
# #' @examples
# #' # Coo example
# #' df <- data.frame(foo_id=40:1, fake1=rnorm(40), fake2=factor(rep(letters[1:4], 10)))
# #' bot <- mutate(bot, hello=1:length(bot))
# #' bind_db(bot, "hello", df, "foo_id")
# #'
# #' # example on a Coe
# #' bf <- efourier(bot, 12)
# #' bind_db(bf, "hello", df, "foo_id")
# #'
# #' @export
# bind_db <- function(x, fac_col="id", db, db_col="id", ...){
# UseMethod("bind_db")
# }
#
# #' @export
# bind_db.default <- function(x, ...){
# message("only implemented on Coo and Coe objects")
# }
#'
# #' @export
# bind_db.Coo <- function(x, fac_col="id", db, db_col="id", ...){
# # checks a bit on x if its a Coo (waiting for verify.Coe todo)
# if (is_Coo(x))
# x <- verify(x)
# .check(!missing(db),
# "db must be provided")
# # if db is provided as a path
# if (is.character(db))
# db <- utils::read.table(db, ...)
# # lots of check
# .check(is.data.frame(db),
# "db must be a data.frame")
# .check(nrow(db)==length(x),
# "nrow(db) does not match")
# .check(any(colnames(db)==db_col),
# "db_col not found in db")
# .check(any(colnames(x$fac)==fac_col),
# "fac_col not found")
# x_id <- x$fac[, fac_col]
# db_id <- db[, db_col]
# .check(length(unique(x_id))==length(unique(db_id)),
# "number of unique id must match")
# map_id <- match(db_id, x_id)
# .check(all(!is.na(map_id)),
# "ids mismatch")
# # finally prepare the db
# db_lite <- db[map_id, ] # reorders
# db_lite <- db_lite[, -which(colnames(db_lite)==db_col)] # -dbcol doesnt work!?
# # and adds it to fac
# x$fac <- cbind(x$fac, db_lite)
# x
# }
#
# #' @export
#' bind_db.Coe <- bind_db.Coo
# helpers ######################################################################
#' Extracts structure from filenames
#'
#' If filenames are consistently named with the same character serating factors,
#' and with every individual including its belonging levels, e.g.:
#' \itemize{
#' \item \code{001_speciesI_siteA_ind1_dorsalview}
#' \item \code{002_speciesI_siteA_ind2_lateralview} } etc., this function returns a \link{data.frame}
#' from it that can be passed to \link{Out}, \link{Opn}, \link{Ldk} objects.
#'
#' The number of groups must be consistent across filenames.
#' @param lf a list (its names are used, except if it is a list from \link{import_tps}
#' in this case \code{names(lf$coo)} is used) of a list of filenames, as characters, typically such as
#' those obtained with \link{list.files}. Alternatively, a path to a folder
#' containing the files. Actually, if lf is of length 1 (a single character),
#' the function assumes it is a path and do a \link{list.files} on it.
#' @param names the names of the groups, as a vector of characters which length corresponds
#' to the number of groups.
#' @param split character, the spliting factor used for the file names.
#' @param trim.extension logical. Whether to remove the last for characters in
#' filenames, typically their extension, e.g. '.jpg'.
#' @return data.frame with, for every individual, the corresponding level
#' for every group.
#' @note This is, to my view, a good practice to 'store' the grouping structure
#' in filenames, but it is of course not mandatory.
#'
#' Note also that you can: i) do a \link{import_jpg} and save is a list, say 'foo';
#' then ii) pass 'names(foo)' to lf_structure. See Momocs' vignette for an illustration.
#'
#' @note Note this function will be deprecated from Momocs
#' when \code{Momacs} and \code{Momit}
#' will be fully operationnal.
#'
#' @seealso \link{import_jpg1}, \link{import_Conte}, \link{import_txt}, \link{lf_structure}.
#' See also Momocs' vignettes for data import.
#' @family babel functions
#' @export
lf_structure <- function(lf, names = character(), split = "_",
trim.extension = FALSE) {
# after import_tps case
if (is.list(lf)) {
# we handle the import_tps case
if (identical(names(lf), c("coo", "cur", "scale")))
lf <- names(lf$coo)
else
lf <- names(lf)
}
# allow to pass many thing, including $fac columns
if (!is.character(lf)) lf <- as.character(lf)
# eg a path
if (length(lf) == 1) {
lf <- list.files(lf, full.names = FALSE)
}
if (trim.extension) {
lf <- strtrim(lf, nchar(lf) - 4)
}
lf0 <- strsplit(lf, split = split)
# we check that all files have the same name structure
lfl <- sapply(lf0, length)
nc <- unique(lfl)
### todo. which ones ?
if (length(nc) != 1) {
most.ab <- as.numeric(names(sort(table(lfl), decreasing = TRUE)[1]))
lfl.pb <- which(lfl != most.ab)
cat(" * Most of the filenames have", most.ab, "groups.\n",
" * Maybe you should inspect these file(name)s:\n")
cat(lf[lfl.pb], sep = "\n")
stop("the files do not have the same filename structure.")
}
fac <- as.data.frame(matrix(NA, nrow = length(lf), ncol = nc)) # dirty
if (!missing(names)) {
if (length(names) != nc) {
stop("the number of 'names' is different from the number of groups.")
}
names(fac) <- names
}
# no rownames
rownames(fac) <- NULL
for (i in 1:nc) {
# really ugly way to fill the df
fac[, i] <- factor(sapply(lf0, function(x) x[i]))
}
return(tibble::as_tibble(fac))
}
#' Binds .jpg outlines from .txt landmarks taken on them
#'
#' Given a list of files (lf) that includes matching filenames with .jpg (black masks)
#' and .txt (landmark positions on them as .txt), returns an Out with $ldk defined.
#' Typically be useful if you use ImageJ to define landmarks on your outlines.
#'
#' @param lf a list of filenames
#' @note Not optimized (images are read twice). Please do not hesitate to contact me
#' should you have a particular case or need something.
#' @return an Out object
#' @family babel functions
#' @export
tie_jpg_txt <- function(lf){
# check pairs
mismatches <- lf %>% .trim.both() %>%
table %>% `!=`(2) %>% which
if (length(mismatches)>0)
stop("* mismatches found between .jpg and .txt filenames: ", names(mismatches))
# we retrieve the list of .txt et.jpg
out.lf <- lf[grep(".jpg", lf)]
ldk.lf <- lf[grep(".txt", lf)]
# we extract outline coordinates
out.xy <- import_jpg(out.lf)
# and landmark coordinates
ldk.xy <- import_txt(ldk.lf)
# below, we bind together landmarks and outlines but we need to 'invert' y-coordinates
# here we extract the nb of pixels in y (nrow)
nrs <- numeric()
for (i in seq_along(out.lf)){
nrs[i] <- nrow(jpeg::readJPEG(out.lf[i]))
}
# here, the loop that 'inverts'
res.pos <- list()
for (i in seq_along(out.xy)){
out1 <- out.xy[[i]]
ldk1 <- ldk.xy[[i]]
ldk1[, 2] <- round(nrs[i] - ldk1[, 2])
res.pos[[i]] <- edm_nearest(ldk1, out1, TRUE)$pos
}
# we now create a Out with all information
Out <- Out(out.xy, ldk = res.pos)
# we align it and then save it
# Out <- coo_slide(Out, ldk=1)
# Out <- coo_bookstein(Out)
return(Out)
}
#' Plots a .jpg image
#'
#' A very simple image plotter. If provided with a path,
#' reads the .jpg and plots it. If not provided with an imagematrix, will
#' ask you to choose interactively a \code{.jpeg} image.
#'
#' \code{img_plot} is used in import functions such as \link{import_jpg1};
#' \code{img_plot0} does the same job but preserves the \code{par} and plots axes.
#'
#' @param img a matrix of an image, such as those obtained with \link{readJPEG}.
#' @return a plot
#' @rdname img_plot
#' @export
img_plot <- function(img) {
# dirty here but made for convenience to have a fast img
# plotter..
if (missing(img)) {
source <- file.choose()
img <- jpeg::readJPEG(source)
cat("img_plot('", source, "')\n", sep = "")
}
if (is.character(img)) {
img <- jpeg::readJPEG(img)
}
if (!is.matrix(img)) {
img <- (img[, , 1] + img[, , 2] + img[, , 3])/3
}
op <- par(mar = rep(0.25, 4))
on.exit(par(op))
# op <- par(mar=rep(4, 4))
h <- nrow(img)
w <- ncol(img)
plot(NA, xlim = c(1, w), ylim = c(1, h), asp = 1, frame = FALSE,
axes = FALSE, ann = FALSE)
# plot(NA, xlim=c(1, w), ylim=c(1, h), asp=1, frame=TRUE,
# axes=TRUE, ann=TRUE)
rasterImage(img, 1, 1, w, h, interpolate = FALSE)
# rect(1, 1, w, h, col=NA, border='red')
.title(paste(w, h, sep = " x "))
box()
}
#' @rdname img_plot
#' @export
img_plot0 <- function(img) {
# dirty here but made for convenience to have a fast img
# plotter..
if (missing(img)) {
source <- file.choose()
img <- jpeg::readJPEG(source)
cat("img_plot('", source, "')\n", sep = "")
}
if (is.character(img)) {
img <- jpeg::readJPEG(img)
}
if (!is.matrix(img)) {
img <- (img[, , 1] + img[, , 2] + img[, , 3])/3
}
# op <- par(mar=rep(4, 4))
h <- nrow(img)
w <- ncol(img)
img <- img[h:1, ]
plot(NA, xlim = c(1, w), ylim = c(1, h), asp = 1, frame = TRUE,
axes = TRUE, ann = TRUE, xlab = "imgmatrix COLs ids",
ylab = "imgmatrix ROWs ids")
# plot(NA, xlim=c(1, w), ylim=c(1, h), asp=1, frame=TRUE,
# axes=TRUE, ann=TRUE)
rasterImage(img, 1, 1, w, h, interpolate = FALSE)
rect(1, 1, w, h, col = NA, border = "red")
.title(paste(w, h, sep = " x "))
box()
}
# misc ----------------------
# Given a list with individuals containing loci,
# returns a list of loci that contains individuals.
# There must be a more elegant way to do it
.rollup_list <- function(l){
locus_names <- sapply(l, names) %>% as.character() %>% unique()
res <- vector("list", length(locus_names))
names(res) <- locus_names
for (i in seq_along(l)){
for (j in seq_along(l[[i]])){
picked <- names(l[[i]][j])
res[[picked]] <- append(res[[picked]], l[[i]][j])
names(res[[picked]])[length(res[[picked]])] <- names(l)[[i]]
}
}
return(res)
}
Add the following code to your website.
For more information on customizing the embed code, read Embedding Snippets.