Nothing
##### Simple bridges between R classes
# coordinates -------------
#' Convert complex to/from cartesian coordinates
#'
#' @param coo coordinates expressed in the cartesian form
#' @param Z coordinates expressed in the complex form
#' @return coordinates expressed in the cartesian/complex form
#' @family bridges functions
#' @examples
#' shapes[4] %>% # from cartesian
#' coo_sample(24) %>%
#' coo2cpx() %T>% # to complex
#' cpx2coo() # and back
#' @name complex
#' @aliases complex
#' @rdname complex
#' @export
cpx2coo <- function(Z){
cbind(Re(Z), Im(Z)) %>% `colnames<-`(c("x", "y")) %>% return()
}
#' @rdname complex
#' @export
coo2cpx <- function(coo){
if (!is.matrix(coo) & length(coo)==2)
coo %<>% matrix(nrow=1)
complex(real = coo[, 1], imaginary = coo[, 2], length.out=nrow(coo))
}
# shp methods -------------
#' Convert between different classes
#'
#' @param a \code{array} of (x; y) coordinates
#' @param d \code{data.frame} with two columns
#' @param l \code{list} with x and y coordinates as components
#' @param m \code{matrix} of (x; y) coordinates
#' @param index \code{numeric}, the number of coordinates for every slice
#'
#'
#' @note \code{a2m}/\code{m2a} change, by essence, the dimension of the data.
#' \code{m2ll} is used internally to hanle coo and cur in \code{Ldk} objects but may be
#' useful elsewhere
#' @return the data in the required class
#' @examples
#' # matrix/list
#' wings[1] %>% coo_sample(4) %>%
#' m2l() %T>% print %>% # matrix to list
#' l2m() # and back
#'
#' # data.frame/matrix
#' wings[1] %>% coo_sample(4) %>%
#' m2d() %T>% print %>% # matrix to data.frame
#' d2m # and back
#'
#' # list/array
#' wings %>% slice(1:2) %$%
#' coo %>% l2a %T>% print %>% # list to array
#' a2l # and back
#'
#' # array/matrix
#' wings %>% slice(1:2) %$%
#' l2a(coo) %>% # and array (from a list)
#' a2m %T>% print %>% # to matrix
#' m2a # and back
#'
#' # m2ll
#' m2ll(wings[1], c(6, 4, 3, 5)) # grab slices and coordinates
#' @family bridges functions
#' @name bridges
#' @aliases bridges
#' @rdname bridges
#' @export
l2m <- function(l) {
if (length(l) == 1 && is_shp(l[[1]]))
return(l[[1]])
m <- cbind(l$x, l$y)
colnames(m) <- c("x", "y")
return(m)
}
#' @rdname bridges
#' @export
m2l <- function(m) {
return(list(x = m[, 1], y = m[, 2]))
}
#' @rdname bridges
#' @export
d2m <- function(d) {
.check(ncol(d) == 2,
"data.frame must have two columns")
d %>% as.matrix() %>% `colnames<-`(c("x", "y"))
}
#' @rdname bridges
#' @export
m2d <- function(m) {
.check(is_shp(m),
"matrix must be a shp")
dplyr::tibble(x=m[, 1], y=m[, 2])
}
#' @rdname bridges
#' @export
l2a <- function(l) {
.check(length(unique(sapply(l, length))) == 1,
"matrices in list must have the same dimensions")
nr <- nrow(l[[1]])
nc <- 2
ni <- length(l)
a <- array(unlist(l), dim = c(nr, nc, ni), dimnames = list(1:nr,
c("x", "y"), names(l)))
return(a)
}
#' @rdname bridges
#' @export
a2l <- function(a) {
.check(is.array(a) & length(dim(a)==3),
"An array of dimension 3 must be provided")
k <- dim(a)[3]
l <- list()
for (i in 1:k) {
l[[i]] <- a[, , i]
}
return(l)
}
#' @rdname bridges
#' @export
a2m <- function(a) {
# ugly
m <- sapply(a, as.numeric)
nc <- dim(a)[1]
m <- matrix(m, nrow = dim(a)[3], ncol = nc * 2, byrow = TRUE)
colnames(m) <- paste0(rep(c("x", "y"), each = nc), 1:nc)
if (!is.null(dimnames(a))) {
rownames(m) <- dimnames(a)[[3]]
}
return(m)
}
#' @rdname bridges
#' @export
m2a <- function(m) {
# ugly
a <- array(NA,
dim = c(ncol(m)/2, 2, nrow(m)),
dimnames = list(1:(ncol(m)/2), c("x", "y"), rownames(m)))
for (i in 1:nrow(m)) {
a[, , i] <- matrix(m[i, ], ncol = 2)
}
return(a)
}
#' @rdname bridges
#' @export
m2ll <- function(m, index=NULL){
# no slicing case, we return a matrix
if (is.null(index))
return(m)
# slicing case, we slices
.check(sum(index)==nrow(m),
"nrow(m) and sum(index) must match")
start <- cumsum(c(1, index[-length(index)]))
end <- cumsum(index)
ll <- vector("list", length(start))
for (i in seq_along(start)){
ll[[i]] <- m[start[i]:end[i], ]
}
return(ll)
}
# home made melt for Coe
.melt_mat <- function(x){
if (is.null(colnames(x)))
colnames(x) <- 1:ncol(x)
dplyr::tibble(key=rep(colnames(x), each=nrow(x)),
value=as.numeric(x))
}
# as_df methods ------------------
#' Turn Momocs objects into tydy data_frames
#'
#' Used in particular for compatibility with the \code{tidyverse}
#'
#' @param x an object, typically a Momocs object
#' @param retain numeric for use with [scree] methods. Defaut to all. If `<1`,
#' enough axes to retain this proportion of variance; if `>1`, this number of axes.
#' @param ... useless here
#' @return a [dplyr::tibble()]
#' @examples
#' # first, some (baby) objects
#' b <- bot %>% coo_sample(12)
#' bf <- b %>% efourier(5, norm=TRUE)
#' # Coo object
#' b %>% as_df
#' # Coe object
#' bf %>% as_df
#'
#' # PCA object
#' bf %>% PCA %>% as_df # all PCs by default
#' bf %>% PCA %>% as_df(2) # or 2
#' bf %>% PCA %>% as_df(0.99) # or enough for 99%
#'
#' # LDA object
#' bf %>% LDA(~fake) %>% as_df
#' # same options apply
#' @family bridges functions
#' @rdname as_df
#' @export
as_df <- function(x, ...){
UseMethod("as_df")
}
#' @rdname as_df
#' @export
as_df.Coo <- function(x, ...){
# res <- lapply(seq_along(x$coo),
# function(i) data.frame(id=names(x$coo)[i],
# x=x$coo[[i]][, 1],
# y=x$coo[[i]][, 2]))
#
# # if there is a fac
# if (is_fac(x)){
# # create a list of data.frames, each row repeated (number of coefficients) times
# fac <- lapply(seq_along(res), function(i) x$fac[rep(i, nrow(res[[i]])),, drop=FALSE])
# # and cbind them
# res <- lapply(seq_along(res), function(i) dplyr::bind_cols(res[[i]], fac[[i]]))
# }
# #rbind them all and return
# do.call("rbind", res) %>%
# dplyr::as_data_frame() %>%
# return()
dplyr::bind_cols(
tibble::tibble(coo=x$coo),
x$fac
)
}
#' @rdname as_df
#' @export
as_df.Coe <- function(x, ...){
# need this since if no fac, bind_cols wont be happy
if (!is_fac(x))
return(tibble::as_tibble(x$coe))
# shortcut
dplyr::bind_cols(
x$fac,
tibble::as_tibble(x$coe)
)
}
#' @rdname as_df
#' @export
as_df.PCA <- function(x, retain, ...){
scores_df <- tibble::as_tibble(x$x)
# if retain is not provided, all returned
if (missing(retain)){
retain <- nrow(scores_df)
}
# check for too ambitious
if (retain > ncol(scores_df)){
cat("`retain` is too ambitious. All axes returned\n")
retain <- ncol(scores_df)
}
# proportion case
if (retain<1){
retain <- scree_min(x, retain)
}
# select the concerned columns
scores_df <- select(scores_df, 1:retain)
# return fac and scores
dplyr::bind_cols(x$fac, scores_df)
}
#' @rdname as_df
#' @export
as_df.LDA <- function(x, retain, ...){
scores_df <- tibble::as_tibble(x$mod.pred$x)
# if retain is not provided, all returned
if (missing(retain)){
retain <- ncol(scores_df)
}
# check for too ambitious
if (retain > nrow(scores_df)){
cat("`retain` is too ambitious. All axes returned\n")
retain <- ncol(scores_df)
}
# proportion case
if (retain<1){
retain <- scree_min(x, retain)
}
# proportion case
if (retain<1)
retain <- scree_min(x, retain)
# select the concerned columns
scores_df <- select(scores_df, 1:retain)
# now the big one
dplyr::bind_cols(
# actual, predicted, posterior
tibble::tibble(actual = x$f,
predicted = x$mod.pred$class,
posterior = apply(x$mod.pred$posterior, 1, max)),
# the original fac
x$fac,
# and LD scores
scores_df)
}
##### end bridges
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.