/
cl-def-Out.R
executable file
·395 lines (370 loc) · 13.7 KB
/
cl-def-Out.R
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
368
369
370
371
372
373
374
375
376
377
378
379
380
381
382
383
384
385
386
387
388
389
390
391
392
393
394
# Out ---------------
#' Builds an Out object
#'
#' In Momocs, \code{Out}-classes objects are lists of closed \bold{out}lines,
#' with optional components, and on which generic methods such as plotting methods (e.g. \link{stack})
#' and specific methods (e.g. \link{efourier} can be applied.
#' \code{Out} objects are primarily \code{\link{Coo}} objects.
#'
#' @param x a \code{list} of matrices of `(x; y)` coordinates,
#' or an array or an Out object or an Ldk object, or a data.frame (and friends)
#' @param fac (optional) a \code{data.frame} of factors and/or numerics
#' specifying the grouping structure
#' @param ldk (optional) \code{list} of landmarks as row number indices
#' @return an \code{Out} object
#' @family classes
#' @aliases Out
#' @examples
#' methods(class=Out)
#' @export
Out <- function(x, fac = dplyr::tibble(), ldk = list()) {
UseMethod("Out")
}
#' @export
Out.default <- function(x, fac = dplyr::tibble(), ldk = list()) {
if (is_shp(x))
Out(list(x))
else
message("an Out object can only be built from a shape, a list, an array or a Coo object")
}
# for Momit and mom_df
#' @export
Out.data.frame <- function(x, fac = dplyr::tibble(), ldk = list()){
# check if there is a coo column and initiate the Out
.check(any(colnames(x)=="coo"),
"data.frame must have a `coo` column")
res <- Out(x$coo)
x <- dplyr::select(x, -coo)
# if any name column, add/drop
if (any(colnames(x)=="name")){
names(res) <- x$name
x <- dplyr::select(x, -name)
}
# if any ldk column, add/drop it
if (!missing(ldk)){
res$ldk <- ldk
} else {
if (any(colnames(x)=="ldk")){
res$ldk <- x$ldk
x <- dplyr::select(x, -ldk)
}
}
# if cols remains, create a coo from them
if (!missing(fac)){
res$fac <- fac
} else {
if (ncol(x)>0)
res$fac <- x
}
# return this beauty
res
}
#' @export
Out.list <- function(x, fac = dplyr::tibble(), ldk = list()) {
Out <- structure(list(coo = x, fac = fac, ldk = ldk), class=c("Out", "Coo"))
if (!is.null(Out$fac))
Out$fac <- tibble::as_tibble(Out$fac, stringsAsFactors = FALSE)
if (is.null(names(Out))) names(Out) <- paste0("shp", 1:length(Out))
return(Out)
}
#' @export
Out.array <- function(x, fac = dplyr::tibble(), ldk = list()) {
x <- a2l(x)
Out <- Out(x, fac = fac, ldk = ldk)
if (is.null(names(Out))) names(Out) <- paste0("shp", 1:length(Out))
return(Out)
}
#' @export
Out.Coo <- function(x, fac = dplyr::tibble(), ldk = list()) {
Out <- Out(x = x$coo, fac = x$fac, ldk = x$ldk)
if (is.null(names(Out))) names(Out) <- paste0("shp", 1:length(Out))
return(Out)
}
# #' Convert an OutCoe object into an Out object
# #'
# #' Uses the \code{$method} to do the inverse corresponding function. For instance,
# #' an \link{OutCoe} object obtained with \link{efourier}, will be converted to an \link{Out}
# #' object (outlines from harmonic coefficients), using \link{efourier_i}.
# #'
# #' Note that the 'positionnal' coefficients (\code{ao} and \code{co} if any) are lost, so for a proper
# #' comparison between a raw \code{Out} and a \code{Out} from \code{Out -> OutCoe -> Out},
# #' the raw \code{Out} should be centered.
# #'
# #' This method is useful since it allows a direct inspection at how Fourier-based
# #' methods handle outlines, and in particular how they normalize it (when they do). If you
# #' have bad "reconstruction" using \code{as_Out}, this probably means that you have to think
# #' about alternative alignements on the raw outlines. For instance, it is obvious
# #' that normalization does a good job on the bottle example, yet it -pi/2 turns the "outlines"
# #' yet neutral for further analysis (and that can be manage with the argument \code{rotate.shp} in
# #' functions/methods that use reconstructed outlines, e.g. \link{plot.PCA}).
# #' @param object an OutCoe object
# #' @param OutCoe used by \code{as}, useless for the front user
# #' @param nb.pts number of point for the reconstructed outlines
# #' @return an \link{Out} object.
# #' @examples
# #' bot <- coo_center(bot)
# #' bot.f <- rfourier(bot, 120)
# #' bot.fi <- as_Out(bot.f)
# #' op <- par(mfrow=c(1, 2))
# #' stack(bot, title="raw bot")
# #' stack(bot.fi, title="outlines from bot.f")
# #' par(op)
# #' @export
# as_Out <- function(object, OutCoe, nb.pts=120){
# # we swith among methods, with a messsage
# method <- object$method
# if (is.null(method)) {
# stop("'$method' is missing. Not a regular Coe object")
# } else {
# p <- pmatch(tolower(method), c("efourier", "rfourier", "tfourier"))
# method.i <- switch(p, efourier_i, rfourier_i, tfourier_i)
# cph <- switch(p, 4, 2, 2)
# }
# coe <- object$coe
# nb.h <- ncol(coe)/cph
# coo <- list()
# for (i in 1:nrow(coe)){
# ef.i <- coeff_split(coe[i, ], nb.h = nb.h, cph = cph)
# coo[[i]] <- method.i(ef.i, nb.pts = nb.pts)}
# names(coo) <- rownames(coe)
# return(Out(coo, fac=object$fac))}
# # The print method for Out objects
# #' @export
# print.Out <- function(x, ...) {
# Out <- verify(x)
# coo_nb <- length(Out)
# if (coo_nb==0){
# cat("An empty Out object")
# return()
# }
# ### Header
# cat("An Out object with: \n")
# coo_len <- sapply(Out$coo, nrow)
# coo_closed <- sapply(Out$coo, coo_is_closed)
# # number of outlines
# cat(" - $coo:", coo_nb, "outlines")
#
# # number of coordinates
# cat(" (", round(mean(coo_len)), " +/- ", round(sd(coo_len)), " coordinates, ", sep="")
# # outlines closed or not
# if (all(coo_closed)) {
# cat("all closed)\n")
# } else {
# if (any(!coo_closed)) {
# cat("all unclosed)\n")
# } else {
# cat(sum(coo_closed), " closed\n")
# }
# }
# # number of landmarks
# if (length(Out$ldk) != 0) {
# cat(" - $ldk:", length(Out$ldk[[1]]), "landmark(s) defined\n")
# } else {
# #cat(" - No landmark defined\n")
# }
# # we print the fac
# .print.fac(Out$fac)
# }
# OutCoe -----------------------------------------------
#' Builds an OutCoe object
#'
#' In Momocs, \code{OutCoe} classes objects are wrapping around
#' lists of morphometric coefficients, along with other informations,
#' on which generic methods such as plotting methods (e.g. \link{boxplot})
#' and specific methods can be applied.
#' \code{OutCoe} objects are primarily \code{\link{Coe}} objects.
#'
#' @param coe \code{matrix} of harmonic coefficients
#' @param fac (optional) a \code{data.frame} of factors,
#' specifying the grouping structure
#' @param method used to obtain these coefficients
#' @param norm the normalisation used to obtain these coefficients
#' @return an \code{OutCoe} object
#' @details These methods can be applied on \code{Out} objects:
#' @family classes
#' @examples
#' # all OutCoe methods
#' methods(class='OutCoe')
#' @export
OutCoe <- function(coe = matrix(), fac = dplyr::tibble(), method,
norm) {
if (missing(method))
stop("a method must be provided to OutCoe")
OutCoe <- structure(list(coe = coe, fac = fac, method = method, norm = norm),
class=c("OutCoe", "Coe"))
OutCoe$coe %<>% as.matrix()
return(OutCoe)
}
#' @export
print.OutCoe <- function(x, ...) {
OutCoe <- x
if (length(OutCoe$method)>1) {
met <- c("combined:", paste0(OutCoe$method, collapse=" + "))
met <- c(met, "analyses ]\n")
combined <- TRUE
} else {
p <- pmatch(OutCoe$method[1], c("efourier", "rfourier", "sfourier", "tfourier"))
met <- switch(p, "elliptical Fourier", "radii variation (equally spaced radii)",
"radii variation (equally spaced curvilinear abscissa)", "tangent angle")
met <- c(met, "analysis ]\n")
combined <- FALSE}
### Header
cat("An OutCoe object [", met)
cat(rep("-", 20), "\n", sep = "")
coo_nb <- nrow(OutCoe$coe) #nrow method ?
if (!combined){
harm.nb <- ncol(OutCoe$coe)/ifelse(p == 1, 4, 2)
# number of outlines and harmonics
cat(" - $coe:", coo_nb, "outlines described, ")
cat(harm.nb, "harmonics\n")
# lets show some of them for a quick inspection.
# boring, removed it
# cat(" - $coe: 1st harmonic coefficients from random individuals: \n")
# row.eg <- sort(sample(coo_nb, ifelse(coo_nb < 5, coo_nb, 5), replace = FALSE))
# col.eg <- coeff_sel(retain = ifelse(harm.nb > 3, 3, harm.nb), drop = 0, nb.h = harm.nb, cph = ifelse(p == 1, 4, 2))
# print(round(OutCoe$coe[row.eg, col.eg], 3))
# cat("etc.\n")
} else {
harm.nb <- ncol(OutCoe$coe)
# number of outlines and harmonics
cat(" - $coe:", coo_nb, "outlines described, and (total) ")
cat(harm.nb, "coefficients\n")
#cat(" - $coe: harmonic coefficients\n")
}
# we print the fac
.print_fac(OutCoe$fac)
}
# Out symmetry methods ---------
#' Calcuates symmetry indices on OutCoe objects
#'
#' For \link{OutCoe} objects obtained with \link{efourier}, calculates several
#' indices on the matrix of coefficients: \code{AD}, the sum of absolute values of
#' harmonic coefficients A and D; \code{BC} same thing for B and C; \code{amp} the
#' sum of the absolute value of all harmonic coefficients and \code{sym} which is the ratio
#' of \code{AD} over \code{amp}. See references below for more details.
#' @param OutCoe [efourier] objects
#' @return a matrix with 4 colums described above.
#' @references Below: the first mention, and two applications.
#' \itemize{
#' #' \item Iwata, H., Niikura, S., Matsuura, S., Takano, Y., & Ukai, Y. (1998).
#' Evaluation of variation of root shape of Japanese radish (Raphanus sativus L.)
#' based on image analysis using elliptic Fourier descriptors. Euphytica, 102, 143-149.
#' \item Iwata, H., Nesumi, H., Ninomiya, S., Takano, Y., & Ukai, Y. (2002).
#' The Evaluation of Genotype x Environment Interactions of Citrus Leaf Morphology
#' Using Image Analysis and Elliptic Fourier Descriptors. Breeding Science, 52(2),
#' 89-94. doi:10.1270/jsbbs.52.89
#' \item Yoshioka, Y., Iwata, H., Ohsawa, R., & Ninomiya, S. (2004).
#' Analysis of petal shape variation of Primula sieboldii by elliptic fourier descriptors
#' and principal component analysis. Annals of Botany, 94(5), 657-64. doi:10.1093/aob/mch190
#' }
#' @note What we call symmetry here is bilateral symmetry.
#' By comparing coefficients resulting from \link{efourier},
#' with AD responsible for amplitude of the Fourier functions,
#' and BC for their phase, it results in the plane and for
#' fitted/reconstructed shapes that symmetry. As long as your shapes are
#' aligned along their bilateral symmetry axis, you can use the approach
#' coined by Iwata et al., and here implemented in Momocs.
#' @seealso \link{rm_asym} and \link{rm_sym}.
#' @examples
#' bot.f <- efourier(bot, 12)
#' res <- symmetry(bot.f)
#' hist(res[, 'sym'])
#' @export
symmetry <- function(OutCoe) {
UseMethod("symmetry")
}
#' @export
symmetry.OutCoe <- function(OutCoe) {
if (OutCoe$method != "efourier")
stop("can only be applied on OutCoe [efourier] objects")
x <- OutCoe$coe
nb.h <- ncol(x)/4
AD.ids <- c(1:nb.h, ((nb.h * 3 + 1):(nb.h * 4)))
BC.ids <- (nb.h + 1):(nb.h * 3)
AD <- apply(abs(x[, AD.ids]), 1, sum)
BC <- apply(abs(x[, BC.ids]), 1, sum)
amp <- apply(abs(x), 1, sum)
sym <- AD/amp
res <- cbind(AD, BC, amp, sym)
return(res)
}
#' Removes asymmetric and symmetric variation on OutCoe objects
#'
#' Only for those obtained with \link{efourier}, otherwise a message is returned.
#' \code{rm_asym} sets all B and C coefficients to 0; \code{rm_sym} sets
#' all A and D coefficients to 0.
#' @param OutCoe an OutCoe object
#' @return an OutCoe object
#' @references Below: the first mention, and two applications.
#' \itemize{
#' #' \item Iwata, H., Niikura, S., Matsuura, S., Takano, Y., & Ukai, Y. (1998).
#' Evaluation of variation of root shape of Japanese radish (Raphanus sativus L.)
#' based on image analysis using elliptic Fourier descriptors. Euphytica, 102, 143-149.
#' \item Iwata, H., Nesumi, H., Ninomiya, S., Takano, Y., & Ukai, Y. (2002).
#' The Evaluation of Genotype x Environment Interactions of Citrus Leaf Morphology
#' Using Image Analysis and Elliptic Fourier Descriptors. Breeding Science, 52(2),
#' 89-94. doi:10.1270/jsbbs.52.89
#' \item Yoshioka, Y., Iwata, H., Ohsawa, R., & Ninomiya, S. (2004).
#' Analysis of petal shape variation of Primula sieboldii by elliptic fourier descriptors
#' and principal component analysis. Annals of Botany, 94(5), 657-64. doi:10.1093/aob/mch190
#' }
#' @seealso \link{symmetry} and the note there.
#' @examples
#' botf <- efourier(bot, 12)
#' botSym <- rm_asym(botf)
#' boxplot(botSym)
#' botSymp <- PCA(botSym)
#' plot(botSymp)
#' plot(botSymp, amp.shp=5)
#'
#' # Asymmetric only
#' botAsym <- rm_sym(botf)
#' boxplot(botAsym)
#' botAsymp <- PCA(botAsym)
#' plot(botAsymp)
#' # strange shapes because the original shape was mainly symmetric and would need its
#' # symmetric (eg its average) for a proper reconstruction. Should only be used like that:
#' plot(botAsymp, morpho=FALSE)
#' @rdname rm_asym
#' @aliases rm_sym
#' @export
rm_asym <- function(OutCoe) {
UseMethod("rm_asym")
}
#' @rdname rm_asym
#' @export
rm_asym.default <- function(OutCoe) {
cat("can only be applied on OutCoe objects")
}
#' @rdname rm_asym
#' @export
rm_asym.OutCoe <- function(OutCoe) {
if (OutCoe$method != "efourier")
stop("can only be applied on OutCoe [efourier] objects")
x <- OutCoe$coe
nb.h <- ncol(OutCoe$coe)/4
zeros <- (nb.h + 1):(nb.h * 3)
OutCoe$coe[, zeros] <- 0
return(OutCoe)
}
#' @rdname rm_asym
#' @export
rm_sym <- function(OutCoe) {
UseMethod("rm_sym")
}
#' @rdname rm_asym
#' @export
rm_sym.default <- function(OutCoe) {
stop("can only be applied on OutCoe objects")
}
#' @rdname rm_asym
#' @export
rm_sym.OutCoe <- function(OutCoe) {
if (OutCoe$method != "efourier")
stop("can only be applied on OutCoe [efourier] objects")
x <- OutCoe$coe
nb.h <- ncol(OutCoe$coe)/4
zeros <- c(1:nb.h, ((nb.h * 3 + 1):(nb.h * 4)))
OutCoe$coe[, zeros] <- 0
return(OutCoe)
}