Nothing
##### Main Coo (Out/Opn/Ldk) plotters
# plot ----------------------------------------------------
#' Graphical inspection of shapes
#'
#' Allows to plot shapes, individually, for \link{Coo} (\link{Out}, \link{Opn} or \link{Ldk}) objects.
#' @param x the \link{Coo} object
#' @param id the id of the shape to plot, if not provided a
#' random shape is plotted. If passed with \code{'all'} all shapes are plotted,
#' one by one.
#' @param ... further arguments to be passed to \link{coo_plot}
#' @return an interactive plot
#' @family Coo_graphics
#' @examples
#' \dontrun{
#' inspect(bot, 5)
#' inspect(bot)
#' inspect(bot, 5, pch=3, points=TRUE) # an example of '...' use
#' }
#' @export
inspect <- function(x, id, ...){
UseMethod("inspect")
}
#' @export
inspect.Coo <- function(x, id, ...) {
Coo <- x
if (missing(id)) {
repeat {
Coo1 <- sample_n(x, 1)
Coo1 %>% stack(title=names(Coo1), coo_sample=NULL)
readline(prompt = "Press <Enter> to continue, <Esc> to quit...")
}
}
if (id[1] == "all") {
id <- 1:length(Coo)
}
if (is.numeric(id)) {
if (length(id) == 1) {
slice(Coo, id) %>% stack(main = names(Coo)[id], ...)
} else {
for (i in seq(along = id)) {
slice(Coo, id) %>% stack(main = names(Coo)[id], ...)
readline(prompt = "Press <Enter> to continue, <Esc> to quit...")
}
}
}
}
# stack ----------------------------------------------------
#' Family picture of shapes
#'
#' Plots all the outlines, on the same graph, from a \link{Coo} (\link{Out}, \link{Opn} or \link{Ldk})
#' object.
#' @param x The \code{Coo} object to plot.
#' @param cols A \code{vector} of colors for drawing the outlines.
#' Either a single value or of length exactly equals to the number of coordinates.
#' @param borders A \code{vector} of colors for drawing the borders.
#' Either a single value or of length exactly equals to the number of coordinates.
#' @param fac a factor within the $fac slot for colors
#' @param palette a color palette to use when fac is provided
#' @param coo_sample if not NULL the number of point per shape to display (to plot quickly)
#' @param points \code{logical} whether to draw or not points
#' @param first.point \code{logical} whether to draw or not the first point
#' @param centroid \code{logical} whether to draw or not the centroid
#' @param ldk \code{logical}. Whether to display landmarks (if any).
#' @param ldk_pch \code{pch} for these landmarks
#' @param ldk_col color for these landmarks
#' @param ldk_cex \code{cex} for these landmarks
#' @param meanshape \code{logical} whether to add meanshape related stuff (below)
#' @param meanshape_col a color for everything meanshape
#' @param ldk_links \code{logical} whether to draw links (of the mean shape)
#' @param ldk_confell \code{logical} whether to draw conf ellipses
#' @param ldk_contour \code{logical} whether to draw contour lines
#' @param ldk_chull \code{logical} whether to draw convex hull
#' @param ldk_labels \code{logical} whether to draw landmark labels
#' @param slidings \code{logical} whether to draw slidings semi landmarks
#' @param slidings_pch \code{pch} for semi landmarks
#' @param xy.axis whether to draw or not the x and y axes
#' @param title a title for the plot. The name of the \code{Coo} by default
#' @param ... further arguments to be passed to \link{coo_plot}
#' @return a plot
#' @family Coo_graphics
#' @examples
#' \donttest{
#' stack(bot)
#' bot.f <- efourier(bot, 12)
#' stack(bot.f)
#' stack(mosquito, borders='#1A1A1A22', first.point=FALSE)
#' stack(hearts)
#' stack(hearts, ldk=FALSE)
#' stack(hearts, borders='#1A1A1A22', ldk=TRUE, ldk_col=col_summer(4), ldk_pch=20)
#' stack(hearts, fac="aut", palette=col_sari)
#'
#' chaffal <- fgProcrustes(chaff)
#' stack(chaffal, slidings=FALSE)
#' stack(chaffal, meanshape=TRUE, meanshape_col="blue")
#' }
#' @rdname stack.Coo
#' @aliases stack.Coo
#' @aliases stack
#' @name stack
#' @export
stack.Coo <-
function(x,
cols, borders,
fac, palette = col_summer,
coo_sample=120,
points = FALSE, first.point = TRUE, centroid = TRUE,
ldk = TRUE,
ldk_pch = 3, ldk_col = "#FF000055",
ldk_cex = 0.5, ldk_links = FALSE,
ldk_confell = FALSE, ldk_contour = FALSE,
ldk_chull = FALSE, ldk_labels = FALSE,
xy.axis = TRUE, title=substitute(x), ...) {
Coo <- x
# downsize
if (is.numeric(coo_sample)) {
if (all(coo_nb(Coo) >= coo_sample)) {
Coo <- suppressMessages(coo_sample(Coo, coo_sample))
}
}
# we handle for missing cols
if (missing(cols)) {
cols <- rep(NA, length(Coo))
}
# or when provided fro an irregular lenght
if (length(cols) != length(Coo)) {
cols <- rep(cols[1], length(Coo))
}
# same thing for borders
if (missing(borders)) {
borders <- rep("#0000003F", length(Coo))
}
if (length(borders) != length(Coo)) {
borders <- rep(borders[1], length(Coo))
}
# but if fac is provided
if (!missing(fac)){
fac <- fac_dispatcher(Coo, fac)
cols <- NA
borders <- palette(nlevels(fac))[fac]
}
# we define local par (margins)
op <- par(mar = c(3, 3, 2, 1))
on.exit(par(op))
# we calculate data range
wdw <- apply(do.call(rbind, Coo$coo), 2, range)
plot(NA, type = "n",
asp = 1, xlim = wdw[, 1], ylim = wdw[, 2],
las = 1, cex.axis = 2/3,
ann = TRUE, frame = FALSE, main=title)
if (xy.axis) {
abline(h = 0, v = 0, col = "grey80", lty = 2)
}
# should be lapply-ed but how to keep cols/borders ?
if (ldk & length(Coo$ldk) != 0){
ldks <- get_ldk(Coo)
}
for (i in 1:length(Coo)) {
coo_draw(Coo$coo[[i]], col = cols[i], border = borders[i],
points = points, first.point = TRUE, centroid = centroid)
if (ldk & is_ldk(Coo)) {
points(ldks[[i]][, 1], ldks[[i]][ ,2], pch = ldk_pch,
col = ldk_col, cex = ldk_cex)
}
}
}
#' @rdname stack.Coo
#' @export
stack.Ldk <- function(x, cols, borders, first.point = TRUE, centroid = TRUE,
ldk = TRUE, ldk_pch = 20, ldk_col=col_alpha("#000000", 0.5), ldk_cex = 0.3,
meanshape = FALSE, meanshape_col="#FF0000",
ldk_links = FALSE, ldk_confell = FALSE, ldk_contour = FALSE,
ldk_chull = FALSE, ldk_labels = FALSE,
slidings=TRUE, slidings_pch="", xy.axis = TRUE, title=substitute(x), ...) {
Coo <- x
if (missing(cols)) {
cols <- rep(NA, length(Coo))
}
if (length(cols) != length(Coo)) {
cols <- rep(cols[1], length(Coo))
}
if (missing(borders)) {
borders <- rep("#33333355", length(Coo))
}
if (length(borders) != length(Coo)) {
borders <- rep(borders[1], length(Coo))
}
op <- par(mar = c(3, 3, 2, 1))
on.exit(par(op))
wdw <- apply(l2a(lapply(Coo$coo, function(x) apply(x, 2, range))), 2, range)
plot(NA, xlim = wdw[, 1], ylim = wdw[, 2], asp = 1, las = 1,
cex.axis = 2/3, ann = FALSE, frame = FALSE)
title(title)
if (xy.axis) {
abline(h = 0, v = 0, col = "grey80", lty = 2)
}
# semilandmarks lines
if (slidings & is_slidings(Coo)){
sl <- get_slidings(Coo)
for (i in 1:length(sl)) {
lapply(sl[[i]], lines, col=col_alpha("#000000", 0.9))
lapply(sl[[i]], points, col=col_alpha("#000000", 0.5), pch=slidings_pch)
}
}
# points
# for (i in 1:length(Coo)) {
# points(Coo$coo[[i]], pch = ldk_pch, col = ldk_col, cex = ldk_cex)
# }
lapply(get_ldk(Coo), points, pch = ldk_pch, col = ldk_col, cex = ldk_cex)
# semilandmarks
# if (is_slidings(Coo)){
# cur_binded <- get_cur_binded(Coo)
# for (i in 1:length(Coo)) {
# points(cur_binded[[i]], pch = cur_pch, col = ldk_col, cex = ldk_cex*0.25)
# }
# }
# Specific to Ldk not very clean below
# A <- l2a(Coo$coo)
# mA <- MSHAPES(A)
if (meanshape){
A <- l2a(get_ldk(Coo))
mA <- MSHAPES(A)
if (ldk_confell) {
ldk_confell(A, conf = 0.9, col=meanshape_col)
}
if (ldk_contour) {
ldk_contour(A, nlevels = 3, col = meanshape_col)
}
if (ldk_chull) {
ldk_chull(A, col = meanshape_col)
}
if (ldk_links | missing(ldk_links)) {
if (is_links(Coo))
ldk_links(MSHAPES(A), Coo$links, col=ldk_col)
}
if (ldk_labels) {
ldk_labels(MSHAPES(A), col=meanshape_col)
}
points(mA, pch = ldk_pch,
cex = ifelse(ldk_cex > 0.5, ldk_cex * 1.5, 0.5), col = meanshape_col)
}
}
# stack2 ----
# #' Family picture of shapes (ggplot2)
# #'
# #' Will replace stack soon.
# #' @param Coo a Coo object
# #' Family picture of shapes
# #' @return a ggplot2 object
# #' @examples
# #' stack2(bot)
# #' @export
# stack2 <- function(Coo){
# df <- as_df(Coo)
# gg <- ggplot2::ggplot(df, aes_string(x="x", y="y", group="id")) +
# ggplot2::geom_path() +
# ggplot2::coord_equal()
# gg
# }
# panel ---------------------------------------------------
#' Family picture of shapes
#'
#' Plots all the outlines, side by side, from
#' a \link{Coo} (\link{Out}, \link{Opn} or \link{Ldk}) objects.
#'
#' @param x The \code{Coo} object to plot.
#' @param dim for \link{coo_listpanel}: a numeric of length 2
#' specifying the dimensions of the panel
#' @param cols A \code{vector} of colors for drawing the outlines.
#' Either a single value or of length exactly equal to the number of coordinates.
#' @param borders A \code{vector} of colors for drawing the borders.
#' Either a single value or of length exactly equals to the number of coordinates.
#' @param fac a factor within the $fac slot for colors
#' @param palette a color \link{palette}
#' @param coo_sample if not NULL the number of point per shape to display (to plot quickly)
#' @param names whether to plot names or not. If TRUE uses shape names, or something for [fac_dispatcher]
#' @param cex.names a cex for the names
#' @param points \code{logical} (for Ldk) whether to draw points
#' @param points.pch (for Ldk) and a pch for these points
#' @param points.cex (for Ldk) and a cex for these points
#' @param points.col (for Ldk) and a col for these points
#' @param ... additional arguments to feed generic \code{plot}
#' @note If you want to reorder shapes according to a factor, use \link{arrange}.
#' @return a plot
#' @family Coo_graphics
#' @examples
#' panel(mosquito, names=TRUE, cex.names=0.5)
#' panel(olea)
#' panel(bot, c(4, 10))
#' # an illustration of the use of fac
#' panel(bot, fac='type', palette=col_spring, names=TRUE)
#' @aliases panel.Coo
#' @rdname panel.Coo
#' @export
panel <- function(x, ...) {
UseMethod("panel")
}
#' @rdname panel.Coo
#' @export
panel.Out <- function(x, dim, cols, borders, fac,
palette = col_summer, coo_sample=120, names = NULL, cex.names = 0.6, points = TRUE,
points.pch = 3, points.cex = 0.2, points.col, ...) {
op <- par("mar", "oma")
on.exit(par(op))
par(mar = rep(1.2, 4), oma = rep(0.2, 4))
Coo <- x
Coo <- coo_template(Coo, size = 0.95)
if (is.numeric(coo_sample)) {
if (all(coo_nb(Coo) >= coo_sample)) {
Coo <- suppressMessages(coo_sample(Coo, coo_sample))
}
}
if (!missing(fac)) {
f <- fac_dispatcher(Coo, fac)
if (missing(cols)) {
cols <- palette(nlevels(f))[f]
} else {
cols <- cols[f]
}
}
if (missing(cols)) {
cols <- rep(NA, length(Coo))
}
if (length(cols) != length(Coo)) {
cols <- rep(cols[1], length(Coo))
}
if (missing(borders)) {
borders <- rep("#333333", length(Coo))
}
if (length(borders) != length(Coo)) {
borders <- rep(borders[1], length(Coo))
}
pos <- coo_listpanel(Coo$coo, dim=dim, cols = cols, borders = borders,
poly = TRUE, ...)
if (!is.null(names)) {
if (is.logical(names)) {
text(pos[, 1], pos[, 2], labels = names(Coo), cex = cex.names)
} else {
names <- fac_dispatcher(Coo, names) %>% as.character()
text(pos[, 1], pos[, 2],
labels = names, cex = cex.names)
}
}
}
# #' @rdname panel.Coo
# #' @export
# panel.OutCoe <- function(x, nb.pts=120, ...){
# OutCoe <- x
# Out <- as.Out(x, nb.pts=nb.pts)
# panel(Out, title=paste0(substitute(x),".i"),...)}
#' @rdname panel.Coo
#' @export
panel.Opn <- function(x, cols, borders, fac,
palette = col_summer, coo_sample=120, names = NULL, cex.names = 0.6, points = TRUE,
points.pch = 3, points.cex = 0.2, points.col, ...) {
op <- par("mar", "oma")
on.exit(par(op))
par(mar = rep(0, 4), oma = rep(0.2, 4))
Coo <- x
Coo <- coo_template(Coo, size = 0.95)
if (is.numeric(coo_sample)) {
if (all(coo_nb(Coo) >= coo_sample)) {
Coo <- suppressMessages(coo_sample(Coo, coo_sample))
}
}
if (!missing(fac)) {
f <- fac_dispatcher(Coo, fac)
if (missing(cols)) {
cols <- palette(nlevels(f))[f]
} else {
cols <- cols[f]
}
}
if (missing(cols)) {
cols <- rep(NA, length(Coo))
}
if (length(cols) != length(Coo)) {
cols <- rep(cols[1], length(Coo))
}
if (missing(borders)) {
borders <- rep("#333333", length(Coo))
}
if (length(borders) != length(Coo)) {
cols <- rep(borders[1], length(Coo))
}
pos <- coo_listpanel(Coo$coo, cols = cols, borders = borders, poly = FALSE, ...)
if (!is.null(names)) {
if (is.logical(names)) {
text(pos[, 1], pos[, 2], labels = names(Coo), cex = cex.names)
} else {
if (length(names) != length(Coo)) {
text(pos[, 1], pos[, 2], labels = Coo$fac[,
names], cex = cex.names)
} else {
text(pos[, 1], pos[, 2], labels = names, cex = cex.names)
}
}
}
}
#' @rdname panel.Coo
#' @export
panel.Ldk <- function(x, cols, borders, fac,
palette = col_summer, names = NULL, cex.names = 0.6, points = TRUE,
points.pch = 3, points.cex = 0.2, points.col = "#333333",
...) {
op <- par("mar", "oma")
on.exit(par(op))
par(mar = rep(0, 4), oma = rep(0.2, 4))
Coo <- x
Coo <- coo_template(Coo, size = 0.95)
if (missing(cols) & !missing(borders))
borders <- cols
if (!missing(fac)) {
f <- fac_dispatcher(Coo, fac)
if (missing(borders)) {
borders <- palette(nlevels(f))[f]
} else {
borders <- borders[f]
}
}
if (missing(borders)) {
borders <- rep("#000000", length(Coo))
}
if (length(borders) != length(Coo)) {
borders <- rep(borders[1], length(Coo))
}
pos <- coo_listpanel(Coo$coo, cols = NULL, borders = NULL,
poly = FALSE, points = points, points.pch = "",
points.cex = points.cex, points.col = points.col, ...)
### quick and dirty patch for slidings, links, etc.
# links
if (is_links(Coo)){
links <- Coo$links
ldk_all <- get_ldk(Coo)
for (i in seq_along(Coo)){
ldk_i <- coo_trans(ldk_all[[i]], pos[i, 1], pos[i, 2])
for (j in 1:nrow(links))
segments(ldk_i[links[j, 1], 1], ldk_i[links[j, 1], 2],
ldk_i[links[j, 2], 1], ldk_i[links[j, 2], 2],
#col=col_alpha("#000000", 0.75))
col=col_alpha(borders[i], 0.9))
}
}
# slidings
if (is_slidings(Coo)){
slidings_all <- get_slidings(Coo)
for (i in seq_along(slidings_all))
for (j in seq_along(slidings_all[[i]]))
lines(coo_trans(slidings_all[[i]][[j]], pos[j, 1], pos[j, 2]),
col=col_alpha(borders[j], 0.75))
}
# ldk
ldk_all <- get_ldk(Coo)
for (i in seq_along(Coo)){
ldk_i <- coo_trans(ldk_all[[i]], pos[i, 1], pos[i, 2])
for (j in 1:nrow(ldk_i))
points(ldk_i[j, 1], ldk_i[j, 2], col=borders[i], pch=points.pch, cex=points.cex)
}
if (!is.null(names)) {
if (is.logical(names)) {
text(pos[, 1], pos[, 2], labels = names(Coo), cex = cex.names)
} else {
if (length(names) != length(Coo)) {
text(pos[, 1], pos[, 2], labels = Coo$fac[, names], cex = cex.names)
} else {
text(pos[, 1], pos[, 2], labels = names, cex = cex.names)
}
}
}
}
# panel2 -----
# #' Family picture of shapes (ggplot2)
# #'
# #' May replace panel one day.
# #' @param Coo a Coo object
# #' @return a ggplot2 object
# #' @examples
# #' panel2(shapes)
# #' @family Coo_graphics
# #' @export
# panel2 <- function(Coo){
# df <- as_df(Coo)
# gg <- ggplot(df, aes_string(x="x", y="y", group="id")) +
# geom_path() +
# coord_equal() + facet_wrap( ~ id)
# gg
# }
##### end graphics Coo
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.