R/RSQ_FUNC.R

In 18kimn/yalestats:

#' RSQ_FUNC function
#'
#' This is one of a few functions created by Joe Cauteruccio, Jessie Li, Andrew West of Yale University that are used together to create the hclust_eval() function.
#'@keywords RSQ_FUNC
#'@export
RSQ_FUNC <- function(mod_dat, cut_mat, dim_obs) {

  # SS at levels
  SS_vect <- rep(NA, dim_obs)
  x_bar_all <- apply(mod_dat, 2, mean)
  tot_ss <- sum(apply(mod_dat, 1, function(x) (dist(rbind(x, x_bar_all))^2)))

  for (i in (dim_obs:1)) {
    # Get Clusters in H

    clus_g <- unique(cut_mat[, i])
    level_PG <- 0

    for (k in clus_g) {
      need_rows <- which(cut_mat[, i] %in% k)

      if (length(need_rows) > 1) {
        x_bar_k <- apply(mod_dat[need_rows, ], 2, mean)
        w_k <- sum(apply(mod_dat[need_rows, ], 1, function(x) (dist(rbind(x, x_bar_k))^2)))
      }

      if (length(need_rows) == 1) {
        x_bar_k <- mod_dat[need_rows, ]
        w_k <- dist(rbind(mod_dat[need_rows, ], x_bar_k))^2
      }

      level_PG <- level_PG + w_k

    }

    SS_vect[i] <- 1 - (level_PG/tot_ss)
  }

  return(SS_vect)

}