R/cl-def-CooCoe.R

Defines functions names.Coe names.Coo dim.Coe dim.Coo length.Coe length.Coo str.Coe str.Coo print.Coo Coe Coo

Documented in Coe Coo

##### Coo and Coe classes declarations, domestic functions and
##### helpers.

#' Coo "super" class
#'
#' \code{Coo} class is the 'parent' or 'super' class of
#' \code{\link{Out}}, \code{\link{Opn}} and \code{\link{Ldk}} classes.
#'
#' Useful shortcuts are described below. See \code{browseVignettes("Momocs")} for
#' a detail of the design behind Momocs' classes.
#'
#' @param ... anything and, anyway, this function will simply returns a message.
#'
#'@details
#' \code{Coo} class is the 'parent' class of the following 'child' classes \itemize{
#' \item \code{\link{Out}} for closed \bold{out}lines
#' \item \code{\link{Opn}} for \bold{op}e\bold{n} outlines
#' \item \code{\link{Ldk}} for configuration of \bold{l}an\bold{d}mar\bold{k}s
#' }
#'
#' Since all 'child classes' of them handle \eqn{(x; y)} coordinates among other generic methods,
#' but also all have their specificity, this architecture allow to recycle generic methods and
#' to use specific methods.
#'
#' In other words, \code{\link{Out}}, \code{\link{Opn}} and \code{\link{Ldk}} classes
#' are all, primarily, \code{Coo} objects on which we define generic \emph{and}
#' specific methods. See their respective help pages for more help.
#'
#' `Coo` objects all have the following components:
#'  * `$coo` which is a list of matrices for coordinates
#'  * `$fac` a `data_frame` for covariates (if any). You can provide
#'  this data_frame directly, as long as it has as many rows as there are matrices in `$coo` (see examples),
#'  or use an helper function such as [lf_structure].
#'
#' You can access all the methods available for \code{Coo} objects
#' with \code{methods(class=Coo)}.
#'
#' @return a list of class Coo
#' @family classes
#' @examples
#' # to see all methods for Coo objects.
#' methods(class='Coo')
#'
#' # to see all methods for Out objects.
#' methods(class='Out') # same for Opn and Ldk
#'
#' # Let's take an Out example. But all methods shown here
#' # work on Ldk (try on 'wings') and on Opn ('olea')
#' bot
#'
#' # Primarily a 'Coo' object, but also an 'Out'
#' class(bot)
#' inherits(bot, "Coo")
#' panel(bot)
#' stack(bot)
#'
#' # Getters (you can also use it to set data)
#' bot[1] %>% coo_plot()
#' bot[1:5] %>% str()
#'
#' # Setters
#' bot[1] <- shapes[4]
#' panel(bot)
#'
#' bot[1:5] <- shapes[4:8]
#' panel(bot)
#'
#' # access the different components
#' # $coo coordinates
#' head(bot$coo)
#' # $fac grouping factors
#' head(bot$fac)
#' # or if you know the name of the column of interest
#' bot$type
#' # table
#' table(bot$fac)
#' # an internal view of an Out object
#' str(bot)
#'
#' # subsetting
#' # see ?filter, ?select, and their 'see also' section for the
#' # complete list of dplyr-like verbs implemented in Momocs
#'
#' length(bot) # the number of shapes
#' names(bot) # access all individual names
#' bot2 <- bot
#' names(bot2) <- paste0('newnames', 1:length(bot2)) # define new names
#'
#' # Add a $fac from scratch
#' coo <- bot[1:5] # a list of five matrices
#' length(coo)
#' sapply(coo, class)
#'
#' fac <- data.frame(name=letters[1:5], value=c(5:1))
#' # Then you have to define the subclass using the right builder
#' # here we have outlines, so we use Out
#' x <- Out(coo, fac)
#' x$coo
#' x$fac
#' @export
Coo <- function(...) {
    message("Coo constructor does not exist alone. See ?Coo")
}

#' Coe "super" class
#'
#'\code{Coe} class is the 'parent' or 'super' class of
#' \code{\link{OutCoe}}, \code{\link{OpnCoe}}, \code{LdkCoe} and \code{TraCoe} classes.
#'
#' Useful shortcuts are described below. See \code{browseVignettes("Momocs")} for
#' a detail of the design behind Momocs' classes.
#'
#' @param ... anything and, anyway, this function will simply returns a message.
#'
#'@details
#' \code{Coe} class is the 'parent' class of the following 'child' classes \itemize{
#' \item \code{\link{OutCoe}} for coefficients from closed \bold{out}lines morphometrics
#' \item \code{\link{OpnCoe}} for coefficients from \bold{op}e\bold{n} outlines morphometrics
#' \item \code{LdkCoe} for coefficients from configuration of \bold{l}an\bold{d}mar\bold{k}s morphometrics.
#' }
#'
#' In other words, \code{\link{OutCoe}}, \code{\link{OpnCoe}} and \code{LdkCoe} classes
#' are all, primarily, \code{Coe} objects on which we define generic \emph{and}
#' specific methods. See their respective help pages for more help.
#'
#' You can access all the methods available for \code{Coe} objects
#' with \code{methods(class=Coe)}.
#'
#' @return a list of class Coe
#' @family classes
#' @examples
#' # to see all methods for Coe objects.
#' methods(class='Coe')
#' # to see all methods for OutCoe objects.
#' methods(class='OutCoe') # same for OpnCoe, LdkCoe, TraCoe
#'
#' bot.f <- efourier(bot, 12)
#' bot.f
#' class(bot.f)
#' inherits(bot.f, "Coe")
#'
#' # if you want to work directly on the matrix of coefficients
#' bot.f$coe
#'
#' #getters
#' bot.f[1]
#' bot.f[1:5]
#'
#' #setters
#' bot.f[1] <- 1:48
#' bot.f[1]
#'
#' bot.f[1:5] <- matrix(1:48, nrow=5, ncol=48, byrow=TRUE)
#' bot.f[1:5]
#'
#' # An illustration of Momocs design. See also browseVignettes("Momocs")
#' op <- opoly(olea, 5)
#' op
#' class(op)
#' op$coe # same thing
#'
#' wp <- fgProcrustes(wings, tol=1e-4)
#' wp
#' class(wp) # for Ldk methods, LdkCoe objects can also be considered as Coo objects
#' # so you can apply all Ldk methods available.
#' wp$coe # Procrustes aligned coordinates
#' @export
Coe <- function(...) {
    message("Coe constructor does not exist alone. See ?Coe")
}

# print ----------

# The print method for Out objects
#' @export
print.Coo <- function(x, n=6, ...) {
  x <- verify(x)
  coo_nb <- length(x)
  if (coo_nb==0){
    cat("empty", class(x)[1])
    return()
  }
  ### Header
  if (is_Out(x)){
    what <- "outlines"
    cat("Out (outlines)\n")
  }
  if (is_Opn(x)){
    what <- "curves"
    cat("Opn (curves)\n")
  }
  if (is_Ldk(x)){
    what <- "landmarks"
    cat("Ldk (landmarks)\n")
  }
  # to speed up printing for large Coo
  if (length(x$coo)>100){
    coo_len <- sapply(sample(x$coo, 100), nrow)
  } else {
    coo_len <- sapply(x$coo, nrow)
  }

  # number of outlines
  cat("  - ", coo_nb, " ", what, ", ",
      round(mean(coo_len)), " +/- ", round(sd(coo_len)), " coords (in $coo)\n", sep="")
  # we print the fac
  #.print_fac(x$fac, n)
  paste0("  - ", ncol(x$fac), " classifiers (in $fac): \n") %>% cat
  # summary(x$fac) %>% print
  .print_fac(x$fac, n=n)
  .other_components(x)
  cat("\n")
}

# str.* ----------------------
# allows to maintain the traditionnal str() behaviour
# actually useless but dont remember why/where
#' @export
str.Coo <- function(object, ...) {
    Coo <- object
    utils::ls.str(Coo)
}
#' @export
str.Coe <- function(object, ...) {
    Coe <- object
    utils::ls.str(Coe)
}

# getters ---------------

#' @export
"[.Coo" <- function(x, i, ...) {
    if (missing(i)) {
        return(x$coo[])
    }
    if (is.integer(i)) {
        return(x$coo[i])
    }
    if (is.numeric(i)) {
        return(x$coo[[i]])
    }
    if (is.character(i)) {
      return(x$coo[[i]])
    }
}

#' @export
"[.Coe" <- function(x, i, ...) {
  if (missing(i)) {
    return(x$coe[])
  }
  if (is.integer(i)) {
    return(x$coe[i, ])
  }
  if (is.numeric(i)) {
    return(x$coe[i, ])
  }
  if (is.character(i)) {
    return(x$coe[i, ])
  }
}

# setters -------------------

#' @export
"[<-.Coo" <- function(x, i, ..., value) {
  if (is.integer(i)) {
    x$coo[i] <- value
    return(x)
  }
  if (is.numeric(i)) {
    x$coo[[i]] <- value
    return(x)
  }
  if (is.character(i)) {
    x$coo[[i]] <- value
    return(x)
  }
}

#' @export
"[<-.Coe" <- function(x, i, ..., value) {
  if (is.integer(i)) {
    x$coe[i, ] <- value
    return(x)
  }
  if (is.numeric(i)) {
    x$coe[i, ] <- value
    return(x)
  }
  if (is.character(i)) {
    x$coo[i, ] <- value
    return(x)
  }
}


# length.* --------------------

#' @export
length.Coo <- function(x) {
    Coo <- x
    return(length(Coo$coo))}

#' @export
length.Coe<- function(x) {
  Coe <- x
  return(nrow(Coe$coe))}

# dim.* ---------------------
#' @export
dim.Coo <- function(x) {
    return(length(Coo$coo))
}

#' @export
dim.Coe <- function(x) {
    return(dim(x$coe))
}

# names.* -------------------
#' @export
names.Coo <- function(x) {
    Coo <- x
    return(names(Coo$coo))
}
#' @export
names.Coe <- function(x) {
    Coe <- x
    return(rownames(Coe$coe))
}

# names<-.* -----------------
#' @export
"names<-.Coo" <- function(x, value) {
    names(x$coo) <- value
    return(x)
}
#' @export
"names<-.Coe" <- function(x, value) {
    rownames(x$coe) <- value
    return(x)
}

# $.* -----------------------

# $ can directly access to $fac colnames
#' @export
`$.Coo` <-
  function (x, name)
  {
    a <- x[[name]]
    if (!is.null(a))
      return(a)
    a <- x$fac[[name]]
    if (!is.null(a))
      return(a)
    a <- x[[name, exact = FALSE]]
    if (!is.null(a) && getOption("warnPartialMatchDollar", default = FALSE)) {
      names <- names(x)
      warning(gettextf("Partial match of '%s' to '%s' in data frame",
                       name, names[pmatch(name, names)]))
    }
    return(a)
  }

#' @export
`$.Coe` <- `$.Coo`

#' @export
`$.PCA` <- `$.Coo`
MomX/Momocs documentation built on Nov. 18, 2023, 10:53 p.m.