Nothing
# class appenders ------------------------------------------
.prepend_class <- function(x, class_to_add){
if (!(class_to_add %in% class(x)))
class(x) %<>% c(class_to_add, .)
x
}
.append_class <- function(x, class_to_add){
if (!(class_to_add %in% class(x)))
class(x) %<>% c(., class_to_add)
x
}
# class testers -------------
#' Class and component testers
#'
#' Class testers test if any of the classes of an object _is_ of a given class. For instance
#' `is_PCA` on a [PCA] object (of classes `PCA` and `prcomp`) will return `TRUE`.
#' Component testers check if _there_is_ a particular component (eg `$fac`, etc.) in an object.
#' @param x the object to test
#' @return `logical`
#' @examples
#' is_Coo(bot)
#' is_Out(bot)
#' is_Ldk(bot)
#' is_ldk(hearts) # mind the capitals!
#' @name is
#' @export
is_Coo <- function(x){
ifelse(any(class(x) == "Coo"), TRUE, FALSE)
}
#' @rdname is
#' @export
is_PCA <- function(x){
ifelse(any(class(x) == "PCA"), TRUE, FALSE)
}
#' @rdname is
#' @export
is_LDA <- function(x){
ifelse(any(class(x) == "LDA"), TRUE, FALSE)
}
#' @rdname is
#' @export
is_Out <- function(x){
ifelse(any(class(x) == "Out"), TRUE, FALSE)
}
#' @rdname is
#' @export
is_Opn <- function(x){
ifelse(any(class(x) == "Opn"), TRUE, FALSE)
}
#' @rdname is
#' @export
is_Ldk <- function(x){
ifelse(any(class(x) == "Ldk"), TRUE, FALSE)
}
#' @rdname is
#' @export
is_Coe <- function(x){
ifelse(any(class(x) == "Coe"), TRUE, FALSE)
}
#' @rdname is
#' @export
is_OutCoe <- function(x){
ifelse(any(class(x) == "OutCoe"), TRUE, FALSE)
}
#' @rdname is
#' @export
is_OpnCoe <- function(x){
ifelse(any(class(x) == "OpnCoe"), TRUE, FALSE)
}
#' @rdname is
#' @export
is_LdkCoe <- function(x){
ifelse(any(class(x) == "LdkCoe"), TRUE, FALSE)
}
#' @rdname is
#' @export
is_TraCoe <- function(x){
ifelse(any(class(x) == "TraCoe"), TRUE, FALSE)
}
#' @rdname is
#' @export
is_shp <- function(x){
if (is.matrix(x))
if (ncol(x)==2 & all(!is.na(x)))
return(TRUE)
FALSE
}
#' @rdname is
#' @export
is_fac <- function(x) length(x$fac) > 0
#' @rdname is
#' @export
is_ldk <- function(x) length(x$ldk) > 0
#' @rdname is
#' @export
is_slidings <- function(x) length(x$slidings) > 0
#' @rdname is
#' @export
is_links <- function(x) is.matrix(x$links)
# outliers ---------
#' Identify outliers
#'
#' A simple wrapper around \link{dnorm} that helps identify outliers. In particular,
#' it may be useful on \link{Coe} object (in this case a PCA is first calculated) and also
#' on \link{Ldk} for detecting possible outliers on freshly digitized/imported datasets.
#'
#' @param x object, either Coe or a numeric on which to search for outliers
#' @param conf confidence for dnorm (1e-3 by default)
#' @param nax number of axes to retain (only for Coe),
#' if <1 retain enough axes to retain this proportion of the variance
#' @param ... additional parameters to be passed to PCA (only for Coe)
#' @return a vector of indices
#' @note experimental. dnorm parameters used are \code{median(x), sd(x)}
#' @examples
#' # on a numeric
#' x <- rnorm(10)
#' x[4] <- 99
#' which_out(x)
#'
#' # on a Coe
#' bf <- bot %>% efourier(6)
#' bf$coe[c(1, 6), 1] <- 5
#' which_out(bf)
#'
#' # on Ldk
#' w_no <- w_ok <- wings
#' w_no$coo[[2]][1, 1] <- 2
#' w_no$coo[[6]][2, 2] <- 2
#' which_out(w_ok, conf=1e-12) # with low conf, no outliers
#' which_out(w_no, conf=1e-12) # as expected
#'
#' # a way to illustrate, filter outliers
#' # conf has been chosen deliberately low to show some outliers
#'x_f <- bot %>% efourier
#'x_p <- PCA(x_f)
#'# which are outliers (conf is ridiculously low here)
#'which_out(x_p$x[, 1], 0.5)
#'cols <- rep("black", nrow(x_p$x))
#'outliers <- which_out(x_p$x[, 1], 0.5)
#'cols[outliers] <- "red"
#'plot(x_p, col=cols)
#'# remove them for Coe, rePCA, replot
#'x_f %>% slice(-outliers) %>% PCA %>% plot
#'
#'# or directly with which_out.Coe
#'# which relies on a PCA
#'outliers <- x_f %>% which_out(0.5, nax=0.95) %>% na.omit()
#'x_f %>% slice(-outliers) %>% PCA %>% plot
#' @export
which_out <- function(x, conf, nax, ...){
UseMethod("which_out")
}
#' @export
which_out.default <- function(x, conf=1e-3, ...){
out <- which(dnorm(x, median(x), sd(x)) < conf)
if(length(out)==0) {
return(NA)
} else {
return(out)}
}
#' @export
which_out.Coe <- function(x, conf=1e-3, nax=0.99, ...){
p <- PCA(x, ...)
if (length(nax)==1){
if (nax < 1)
nax <- scree_min(p, nax)
}
m <- p$x[, 1:nax]
m <- matrix(m, ncol=nax)
outliers <- apply(m, 2, which_out, conf=conf)
outliers <- unlist(outliers)
outliers %>% as.numeric %>%
na.omit %>% unique %>% return()
}
#' @export
which_out.Ldk <- function(x, conf=1e-3, ...){
arr <- x$coo %>% l2a %>% apply(1:2, function(.) dnorm(., mean(.), sd(.)))
out <- which(arr < conf, arr.ind=TRUE)
if (nrow(out)==0){
return(NA)
} else {
message("found ", nrow(arr), " possible outliers")
dplyr::tibble(shape=names(x)[out[, 1]],
id=out[, 1],
row=out[, 2],
coordinate=c("x", "y")[out[, 3]])
}
}
##### End Miscellaneous
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.