Improve s3 methods

NAMESPACE

@@ -4,6 +4,8 @@ S3method(plot,dpca)
 S3method(plot,spca)
 S3method(print,dpca)
 S3method(print,spca)
+S3method(print,summary.dpca)
+S3method(print,summary.spca)
 S3method(summary,dpca)
 S3method(summary,spca)
 export(dpca)

R/dpca.R

@@ -53,7 +53,9 @@
 #' @return A object of class "dpca" wrapping a list with the entries
 #' \itemize{
 #'   \item \code{xmean}: a vector holding the mean of each cross-sectional unit
-#'   \item \code{spectrum}: the estimated spectral density
+#'   \item \code{spectrum}: the estimated spectral density without the
+#'     normalization by a factor of 2 \code{pi}. Therefore, a white noise
+#'     process would have a spectrum equal to one a.e.
 #'   \item \code{eig}: eigen decomposition of the spectral density
 #'   \item \code{filter}: a list holding the filter coefficients for the filter
 #'     returning input and dynamic common component.
@@ -138,6 +140,7 @@ dpca <- function(
   }
   nx <- nrow(x)
   tx <- ncol(x)
+  cl <- match.call()
 
   if (!missing(q) && (length(q) > 1 || floor(abs(q)) != q)) {
     stop("\"q\" has to be a single positive integer!")
@@ -195,13 +198,14 @@ dpca <- function(
     as.numeric(penalty_scales),
     PACKAGE = "dpca"
   )
-
   ## add cross-sectional means
   res$xmean <- mx
   if (select_q) {
     res$HL_select$penalty_scales <- penalty_scales
   }
 
+  res$call <- cl
+  res$freqs <- freqs
   class(res) <- "dpca"
   res
 }

R/s3methods.R

@@ -5,39 +5,120 @@
 #' @param ... Further pass-through arguments.
 #' @export
 print.dpca <- function(x, ...) {
-  cat("\nDynamic principal component estimation object:\n")
-  cat(sprintf("  Number of selected dynamic components: %s\n", x$HL_select$q))
+  cat("\nDynamic principal component estimation\n")
+  cat("\nCall:\n", paste(deparse(x$call), sep = "\n", collapse = "\n"),
+    "\n\n",
+    sep = ""
+  )
+  cat(paste("Number of dynamic components:", dim(x$ndpc)[1]), "\n")
 }
 
 #' Summary method for object of class \code{dpca}.
 #' @param object An object of type \code{spca}.
 #' @param ... Further pass-through arguments.
 #' @export
-summary.dpca <- function(object, ...) print.dpca(object)
+summary.dpca <- function(object, ...) {
+  ps <- object$eig$vectors
+  lambda <- object$eig$values
+  ndim <- dim(ps)[2]
+  spec_chi <- vapply(seq_along(object$freqs), function(i) {
+    crossprod(
+      Conj(ps[, , i]) * lambda[, i], ps[, , i]
+    )
+  }, matrix(0i, nrow = ndim, ncol = ndim))
+
+  z <- list()
+  z$freqs <- object$freqs
+  z$gamma <- apply(object$spectrum, c(1, 2), sum) / length(object$freqs)
+  z$gamma_chi <- apply(spec_chi, c(1, 2), sum) / length(object$freqs)
+  z$q <- dim(ps)[1]
+  z$object <- object
+
+  class(z) <- "summary.dpca"
+  z
+}
+
+#' Summary method for object of class \code{summary.dpca}.
+#'
+#' @param x An object of type \code{summary.dpca}.
+#' @param ... Further pass-through arguments.
+#' @export
+print.summary.dpca <- function(x, ...) {
+  trace_chi <- Re(sum(diag(x$gamma_chi)))
+  trace_x <- Re(sum(diag(x$gamma)))
+  cat("\nDynamic principal component estimation summary\n\n")
+  cat("\nCall:\n", paste(deparse(x$object$call), sep = "\n", collapse = "\n"),
+    "\n\n",
+    sep = ""
+  )
+  cat(paste("Number of dynamic components:", x$q, "\n"))
+  cat(paste("Proportion of explained total variance: ", round(trace_chi / trace_x, 2), "\n"))
+}
 
 #' Print method for object of class \code{spca}.
 #' @param x An object of type \code{spca}.
 #' @param ... Further pass-through arguments.
 #' @export
 print.spca <- function(x, ...) {
-  cat("\nStatic principal component estimation object:\n")
-  cat(sprintf("  Number of selected static components: %s\n", x$HL_select$r))
+  cat("\nStatic principal component estimation\n")
+  cat("\nCall:\n", paste(deparse(x$call), sep = "\n", collapse = "\n"),
+    "\n\n",
+    sep = ""
+  )
+  cat(paste("Number of dynamic components:", dim(x$factors)[1]), "\n")
 }
 
 #' Summary method for object of class \code{spca}.
 #' @param object An object of type \code{spca}.
 #' @param ... Further pass-through arguments.
 #' @export
-summary.spca <- function(object, ...) print.spca(object)
+summary.spca <- function(object, ...) {
+  ps <- object$eig$vectors
+  lambda <- object$eig$values
+  cov_chi <- tcrossprod(
+    t(t(ps) * lambda), ps
+  )
 
-#' Plot q-selection graphcs for a \code{dpca} object.
-#' @param x An object of type \code{spca}.
+  z <- list()
+  z$cov <- object$cov
+  z$cov_chi <- cov_chi
+  z$r <- length(lambda)
+  z$object <- object
+
+  class(z) <- "summary.spca"
+  z
+}
+
+#' Summary method for object of class \code{summary.spca}.
+#'
+#' @param x An object of type \code{summary.spca}.
+#' @param ... Further pass-through arguments.
+#' @export
+print.summary.spca <- function(x, ...) {
+  trace_chi <- sum(diag(x$cov_chi))
+  trace_x <- sum(diag(x$cov))
+  cat("basdfadf")
+  cat("\nStatic principal component estimation summary\n\n")
+  cat("\nCall:\n", paste(deparse(x$object$call), sep = "\n", collapse = "\n"),
+    "\n\n",
+    sep = ""
+  )
+  cat(paste("Number of static components:", x$r, "\n"))
+  cat(paste("Proportion of explained total variance: ", round(trace_chi / trace_x, 2), "\n"))
+}
+
+#' Diagnostics plot for a \code{dpca} object.
+#'
+#' @param x An object of type \code{dpca}.
 #' @param ... Further pass-through arguments.
 #' @importFrom graphics axis mtext par
 #' @export
 plot.dpca <- function(x, ...) {
   if (is.null(x$HL_select)) {
-    warning("No data-driven selection of number of dynamic factors for passed object. Nothing to plot!")
+    warning(paste(
+      "No data-driven selection of number of dynamic factors for passed object.",
+      "Nothing to plot!"
+    ))
     return(invisible())
   }
   par(mar = c(5, 4, 4, 6))
@@ -62,6 +143,11 @@
   )
 }
 
+#' Diagnostics plot for an \code{spca} object.
+#'
+#' @param x An object of type \code{spca}.
+#' @param ... Further pass-through arguments.
+#' @importFrom graphics axis mtext par
 #' @export
 plot.spca <- function(x, ...) {
   r_selection <- x$HL_select

R/spca.R

@@ -24,7 +24,7 @@
 #' \itemize{
 #'   \item \code{xmean}: a vector holding the mean of each cross-sectional unit
 #'   \item \code{cov}: variance-covariance-matrix of \code{x}
-#'   \item \code{eig}: eigen decomposition of \code{cov}
+#'   \item \code{eig}: truncated eigen decomposition of \code{cov}
 #'   \item \code{factors}: an \eqn{r} times \eqn{T} dimensional matrix with the computed factors
 #'   \item \code{cc}: (static) common component
 #'   \item \code{ic}: (static) idiosyncratic component
@@ -56,6 +56,7 @@ spca <- function(
   if (is.null(n_path)) {
     n_path <- floor(seq(nrow(x) / 2, nrow(x), nrow(x) / 20))
   }
+  cl <- match.call()
 
   ## centering
   mx <- rowMeans(x)
@@ -100,6 +101,7 @@ spca <- function(
     res$HL_select <- hl_select
   }
   class(res) <- "spca"
+  res$call <- cl
 
   res
 }

tests/testthat/test_dpca.R

@@ -33,7 +33,11 @@ test_that("Test dpca, stepwise", {
   system.time(res_dpca1 <- dpca::dpca(x = x, q = 4, freqs = freqs, bandwidth = bw, weights = "bartlett"))
   system.time(res_freqdom <- freqdom::dpca(t(x), bw, freqs, 4L))
   res_dpca$xmean <- rowMeans(x)
-  class(res_dpca1) <- NULL
+  class(res_dpca) <- "dpca"
+  res_dpca1$call <- NULL
+  res_dpca$call <- NULL
+  res_dpca$freqs <- freqs
+
   expect_equal(res_dpca, res_dpca1)