refactor: run styler::style_pkg()

R/estimate_fpc_scores.R

@@ -6,36 +6,37 @@
 #'
 #' @return
 #'
-estimate_fpc_scores = function(tfb_fpc_obj, Ypred, method = "blup") {
-
-  if (method != "blup") { stop("Only estimation using BLUPs are currently implemented.") }
+estimate_fpc_scores <- function(tfb_fpc_obj, Ypred, method = "blup") {
+  if (method != "blup") {
+    stop("Only estimation using BLUPs are currently implemented.")
+  }
 
-  efunctions = tfb_fpc_obj[["efunctions"]]
-  evalues = tfb_fpc_obj[["evalues"]]
-  mu = tfb_fpc_obj[["mu"]]
-  npc = tfb_fpc_obj[["npc"]]
-  error_var = tfb_fpc_obj[["error_var"]]
+  efunctions <- tfb_fpc_obj[["efunctions"]]
+  evalues <- tfb_fpc_obj[["evalues"]]
+  mu <- tfb_fpc_obj[["mu"]]
+  npc <- tfb_fpc_obj[["npc"]]
+  error_var <- tfb_fpc_obj[["error_var"]]
 
-  D = dim(efunctions)
-  I.pred = dim(Ypred)[1]
+  D <- dim(efunctions)
+  I.pred <- dim(Ypred)[1]
 
-  D.inv = diag(1/evalues, nrow = npc, ncol = npc)
-  Z = efunctions
-  data.tilde = Ypred - matrix(mu, I.pred, D, byrow = TRUE)
-  Yhat = matrix(0, nrow = I.pred, ncol = D)
-  rownames(Yhat) = rownames(Ypred)
-  colnames(Yhat) = colnames(Ypred)
-  scores = matrix(NA, nrow = I.pred, ncol = npc)
+  D.inv <- diag(1 / evalues, nrow = npc, ncol = npc)
+  Z <- efunctions
+  data.tilde <- Ypred - matrix(mu, I.pred, D, byrow = TRUE)
+  Yhat <- matrix(0, nrow = I.pred, ncol = D)
+  rownames(Yhat) <- rownames(Ypred)
+  colnames(Yhat) <- colnames(Ypred)
+  scores <- matrix(NA, nrow = I.pred, ncol = npc)
   for (i.subj in 1:I.pred) {
-    obs.points = which(!is.na(Ypred[i.subj, ]))
-    if (error_var == 0 & length(obs.points) < npc)
+    obs.points <- which(!is.na(Ypred[i.subj, ]))
+    if (error_var == 0 && length(obs.points) < npc) {
       stop("Measurement error estimated to be zero and there are fewer observed points than PCs; scores cannot be estimated.")
-    Zcur = matrix(Z[obs.points, ], nrow = length(obs.points), ncol = dim(Z)[2])
-    ZtZ_sD.inv = solve(crossprod(Zcur) + error_var * D.inv)
-    scores[i.subj, ] = ZtZ_sD.inv %*% t(Zcur) %*% (data.tilde[i.subj, obs.points])
-    Yhat[i.subj, ] = t(as.matrix(mu)) + scores[i.subj, ] %*% t(efunctions)
+    }
+    Zcur <- matrix(Z[obs.points, ], nrow = length(obs.points), ncol = dim(Z)[2])
+    ZtZ_sD.inv <- solve(crossprod(Zcur) + error_var * D.inv)
+    scores[i.subj, ] <- ZtZ_sD.inv %*% t(Zcur) %*% (data.tilde[i.subj, obs.points])
+    Yhat[i.subj, ] <- t(as.matrix(mu)) + scores[i.subj, ] %*% t(efunctions)
   }
 
   scores
-
 }

R/fpca-methods.R

@@ -13,15 +13,15 @@
 ##' @method residuals rfr_fpca
 ##' @aliases fitted.rfr_fpca
 ##' @export
-residuals.rfr_fpca <- function(object, ...){
+residuals.rfr_fpca <- function(object, ...) {
   object$Y - tfd(object$Yhat_tfb, arg = tf_arg(object$Y))
 }
 
 ##' @importFrom stats fitted fitted.values
 ##' @method fitted rfr_fpca
 ##' @export
 ##' @rdname residuals.rfr_fpca
-fitted.rfr_fpca <- function(object, ...){
+fitted.rfr_fpca <- function(object, ...) {
   tfd(object$Yhat_tfb, arg = tf_arg(object$Y))
 }
 
@@ -38,27 +38,27 @@ fitted.rfr_fpca <- function(object, ...){
 ##' @importFrom stats fitted fitted.values
 ##' @method predict rfr_fpca
 ##' @export
-predict.rfr_fpca <- function(object, newdata, ...){
+predict.rfr_fpca <- function(object, newdata, ...) {
   ## need different behavior for regular vs. irregular objects?
-   # nah, just need to make sure it works for irregular objects.
-    # default behavior (with no new data) is to return fitted values
+  # nah, just need to make sure it works for irregular objects.
+  # default behavior (with no new data) is to return fitted values
   if (missing(newdata) || is.null(newdata)) {
     return(fitted(object))
   }
 
   ## include some data checks -- args for new data and fpc expansion, etc
   ## also that `model_var` is included in `newdata`
 
-  model_var = object$model_var
-  new_tf = newdata[[model_var]]
+  model_var <- object$model_var
+  new_tf <- newdata[[model_var]]
 
-  Ypred = as.matrix(spread(tf_unnest(new_tf), key = .data$arg, value = .data$value)[,-1])
+  Ypred <- as.matrix(spread(tf_unnest(new_tf), key = .data$arg, value = .data$value)[, -1])
 
-  new_scores = estimate_fpc_scores(object, Ypred)
+  new_scores <- estimate_fpc_scores(object, Ypred)
 
   coef_list <- split(cbind(1, new_scores), row(cbind(1, new_scores)))
 
-  tfb_ob = object$Yhat_tfb
+  tfb_ob <- object$Yhat_tfb
 
   structure(
     coef_list,
@@ -72,5 +72,4 @@ predict.rfr_fpca <- function(object, newdata, ...){
     error_variance = attr(tfb_ob, "error_variance"),
     class = c("tfb_fpc", "tfb", "tf", "vctrs_vctr")
   )
-
 }

R/fpca-utils.R

@@ -1,17 +1,17 @@
 ##' Convert tfb_fpc object to a list
 ##' @param tfb_fpc_obj object turned by `tfb_fpc`
 ##' @importFrom stats coefficients
-extract_fpca <- function(tfb_fpc_obj){
+extract_fpca <- function(tfb_fpc_obj) {
   # may change this to not return the basis object
-  N = length(tfb_fpc_obj)
-  efunctions = attr(tfb_fpc_obj, "basis_matrix")
-  evalues = attr(tfb_fpc_obj, "score_variance")
-  npc = length(evalues)
-  error_var = attr(tfb_fpc_obj, "error_variance")
+  N <- length(tfb_fpc_obj)
+  efunctions <- attr(tfb_fpc_obj, "basis_matrix")
+  evalues <- attr(tfb_fpc_obj, "score_variance")
+  npc <- length(evalues)
+  error_var <- attr(tfb_fpc_obj, "error_variance")
 
-  coef_list = coefficients(tfb_fpc_obj)
-  score_list = lapply(coef_list, "[", -1)  #drop intercepts
-  scores = do.call("rbind", score_list)
+  coef_list <- coefficients(tfb_fpc_obj)
+  score_list <- lapply(coef_list, "[", -1) # drop intercepts
+  scores <- do.call("rbind", score_list)
 
   fpca_obj <- list(
     Yhat_tfb = tfb_fpc_obj,
@@ -48,12 +48,10 @@ extract_fpca <- function(tfb_fpc_obj){
 #'   refundr:::extract_fpca() %>%
 #'   refundr:::extract_fpc_scores()
 #'
-extract_fpc_scores = function(rfr_fpca_obj){
+extract_fpc_scores <- function(rfr_fpca_obj) {
+  score_mat <- rfr_fpca_obj$scores
 
-  score_mat = rfr_fpca_obj$scores
-
-  colnames(score_mat) = str_c(rfr_fpca_obj$model_var, 1:dim(score_mat)[2], sep = "_score_")
+  colnames(score_mat) <- str_c(rfr_fpca_obj$model_var, 1:dim(score_mat)[2], sep = "_score_")
 
   as_tibble(score_mat)
-
 }