R/test_results.R

Defines functions test_results

Documented in test_results

#' Get RMSE & explained variance for warm and cold test results
#' 
#' @importFrom stats sd cor
#' 
#' @export
#' @param m a \code{CP_model} or \code{Tucker_model} object
#' @param d an input data object created with \code{input_data}
#' @param test.results an object generated by this function that will combined with the new results
#' @param verbose Logical indicating whether to print the resulting prediction measures (TRUE)
#' @param warm.resp True responses for warm test data (optional).
#' @param test.m1 True responses for mode 1 cold test data (optional).
#' @param test.m2 True responses for mode 2 cold test data (optional).
#' @param test.m3 True responses for mode 3 cold test data (optional).
#' @param test.m1m2 True responses for mode 1/2 combination cold test data (optional).
#' @param test.m1m3 True responses for mode 1/3 combination cold test data (optional).
#' @param test.m2m3 True responses for mode 2/3 combination cold test data (optional).
#' @param test.m1m2m3 True responses for mode 1/2/3 combination cold test data (optional).
#' 
#' @return list of results TODO: add more here
#' @examples
#' data.params <- get_data_params(c('decomp=Tucker'))
#' toy <- mk_toy(data.params)
#' 
#' # Make training data object excluding the first two samples for modes 1 & 2.
#' train.data <- input_data$new(mode1.X=toy$mode1.X[-(1:2),-1],
#'                              mode2.X=toy$mode2.X[-(1:2),-1],
#'                              mode3.X=toy$mode3.X[,-1],
#'                              resp=toy$resp)
#' # Remove some responses for warm prediction
#' warm.ind <- sample(1:prod(dim(train.data$resp)), 20)
#' warm.resp <- train.data$resp[warm.ind]
#' train.data$resp[warm.ind] <- NA
#' 
#' # Make testing objects 
#' m1.test.data <- input_data$new(mode1.X=toy$mode1.X[1:2,-1],
#'                                mode2.X=toy$mode2.X[-(1:2),-1],
#'                                mode3.X=toy$mode3.X[,-1],
#'                                resp=toy$resp[1:2,-(1:2),])
#' m2.test.data <- input_data$new(mode1.X=toy$mode1.X[-(1:2),-1],
#'                                mode2.X=toy$mode2.X[1:2,-1],
#'                                mode3.X=toy$mode3.X[,-1],
#'                                resp=toy$resp[-(1:2),1:2,])
#' m1m2.test.data <- input_data$new(mode1.X=toy$mode1.X[1:2,-1],
#'                                  mode2.X=toy$mode2.X[1:2,-1],
#'                                  mode3.X=toy$mode3.X[,-1],
#'                                  resp=toy$resp[1:2,1:2,])
#'                                
#' model.params <- get_model_params(c('decomp=Tucker'))
#' toy.model <- mk_model(train.data, model.params)
#' toy.model$rand_init(model.params)
#' toy.model$iter <- 1
#' 
#' test.results <- numeric(0)
#' test_results(m=toy.model, d=train.data, warm.resp=warm.resp, 
#'              test.m1=m1.test.data, test.m2=m2.test.data, 
#'              test.m1m2=m1m2.test.data)

test_results <- function(m, d, test.results=numeric(0), verbose=T,
                         warm.resp=numeric(0),
                         test.m1=numeric(0), test.m2=numeric(0), test.m3=numeric(0),
                         test.m1m2=numeric(0), test.m1m3=numeric(0), test.m2m3=numeric(0),
                         test.m1m2m3=numeric(0)) {
  
  if(length(test.results)==0) {
    res <- data.frame(matrix(0, 1, 0))
    if(length(warm.resp)) {
      warm.RMSE  <- 0; res$warm.RMSE.clip <- 0
      res$warm.exp.var <- 0; res$warm.exp.var.clip <- 0
      res$warm.p.cor <- 0; res$warm.p.cor.clip <- 0
      res$warm.s.cor <- 0; res$warm.s.cor.clip <- 0
    }
    if(length(test.m1)) {
      res$m1.RMSE <- 0; res$m1.RMSE.clip <- 0
      res$m1.exp.var <- 0; res$m1.exp.var.clip <- 0
      res$m1.p.cor <- 0; res$m1.p.cor.clip <- 0
      res$m1.s.cor <- 0; res$m1.s.cor.clip <- 0
    }
    if(length(test.m2)) {
      res$m2.RMSE <- 0; res$m2.RMSE.clip <- 0
      res$m2.exp.var <- 0; res$m2.exp.var.clip <- 0
      res$m2.p.cor <- 0; res$m2.p.cor.clip <- 0
      res$m2.s.cor <- 0; res$m2.s.cor.clip <- 0
    }
    if(length(test.m3)) {
      res$m3.RMSE <- 0; res$m3.RMSE.clip <- 0
      res$m3.exp.var <- 0; res$m3.exp.var.clip <- 0
      res$m3.p.cor <- 0; res$m3.p.cor.clip <- 0
      res$m3.s.cor <- 0; res$m3.s.cor.clip <- 0
    }
    if(length(test.m1m2)) {
      res$m1m2.RMSE <- 0; res$m1m2.RMSE.clip <- 0
      res$m1m2.exp.var <- 0; res$m1m2.exp.var.clip <- 0
      res$m1m2.p.cor <- 0; res$m1m2.p.cor.clip <- 0
      res$m1m2.s.cor <- 0; res$m1m2.s.cor.clip <- 0
    }
    if(length(test.m1m3)) {
      res$m1m3.RMSE <- 0; res$m1m3.RMSE.clip <- 0
      res$m1m3.exp.var <- 0; res$m1m3.exp.var.clip <- 0
      res$m1m3.p.cor <- 0; res$m1m3.p.cor.clip <- 0
      res$m1m3.s.cor <- 0; res$m1m3.s.cor.clip <- 0
    }
    if(length(test.m2m3)) {
      res$m2m3.RMSE <- 0; res$m2m3.RMSE.clip <- 0
      res$m2m3.exp.var <- 0; res$m2m3.exp.var.clip <- 0
      res$m2m3.p.cor <- 0; res$m2m3.p.cor.clip <- 0
      res$m2m3.s.cor <- 0; res$m2m3.s.cor.clip <- 0
    }
    if(length(test.m1m2m3)) {
      res$m1m2m3.RMSE <- 0; res$m1m2m3.RMSE.clip <- 0
      res$m1m2m3.exp.var <- 0; res$m1m2m3.exp.var.clip <- 0
      res$m1m2m3.p.cor <- 0; res$m1m2m3.p.cor.clip <- 0
      res$m1m2m3.s.cor <- 0; res$m1m2m3.s.cor.clip <- 0
    }
  } else res <- rbind(test.results, NA)

  if(length(warm.resp)) {
    warm.preds <- test(d, m)[is.na(d$resp)]
    res$warm.RMSE[m$iter] <- nrmse(warm.resp, warm.preds)
    warm.preds.clip <- warm.preds
    warm.preds.clip[warm.preds.clip < min(d$resp, na.rm=T)] <- min(d$resp, na.rm=T)
    warm.preds.clip[warm.preds.clip > max(d$resp, na.rm=T)] <- max(d$resp, na.rm=T)
    res$warm.RMSE.clip[m$iter] <- nrmse(warm.resp, warm.preds.clip)
    res$warm.exp.var[m$iter] <- exp_var(warm.resp, warm.preds)
    res$warm.exp.var.clip[m$iter] <- exp_var(warm.resp, warm.preds.clip)
    res$warm.p.cor[m$iter] <- tryCatch(cor(warm.resp, warm.preds, use='complete.obs'), error=function(e) NA)
    res$warm.p.cor.clip[m$iter] <- tryCatch(cor(warm.resp, warm.preds.clip, use='complete.obs'), error=function(e) NA)
    res$warm.s.cor[m$iter] <- tryCatch(cor(warm.resp, warm.preds, use='complete.obs', method='spearman'), error=function(e) NA)
    res$warm.s.cor.clip[m$iter] <- tryCatch(cor(warm.resp, warm.preds.clip, use='complete.obs', method='spearman'), error=function(e) NA)
    if(verbose) {
      print(sprintf('Warm RMSE: %.2f, clipped: %.2f', 
                    res$warm.RMSE[m$iter], res$warm.RMSE.clip[m$iter]))
      print(sprintf("Warm explained variance: %.2f, clipped: %.2f", 
                    res$warm.exp.var[m$iter], res$warm.exp.var.clip[m$iter]))
      print(sprintf("Warm Pearson correlation: %.2f, clipped: %.2f", 
                    res$warm.p.cor[m$iter], res$warm.p.cor.clip[m$iter]))
      print(sprintf("Warm Spearman correlation: %.2f, clipped: %.2f", 
                    res$warm.s.cor[m$iter], res$warm.s.cor.clip[m$iter]))
    }
  }
  
  if(length(test.m1) && sum(!is.na(test.m1$resp))) {
    m1.cold.preds <- test(d=test.m1, m=m)
    res$m1.RMSE[m$iter] <- nrmse(test.m1$resp, m1.cold.preds)
    m1.cold.preds.clip <- m1.cold.preds
    m1.cold.preds.clip[m1.cold.preds.clip < min(d$resp, na.rm=T)] <- min(d$resp, na.rm=T)
    m1.cold.preds.clip[m1.cold.preds.clip > max(d$resp, na.rm=T)] <- max(d$resp, na.rm=T)
    res$m1.RMSE.clip[m$iter] <- nrmse(test.m1$resp, m1.cold.preds.clip)
    res$m1.exp.var[m$iter] <- exp_var(test.m1$resp, m1.cold.preds)
    res$m1.exp.var.clip[m$iter] <- exp_var(test.m1$resp, m1.cold.preds.clip)
    res$m1.p.cor[m$iter] <- tryCatch(cor(test.m1$resp, m1.cold.preds, use='complete.obs'), error=function(e) NA)
    res$m1.p.cor.clip[m$iter] <- tryCatch(cor(test.m1$resp, m1.cold.preds.clip, use='complete.obs'), error=function(e) NA)
    res$m1.s.cor[m$iter] <- tryCatch(cor(test.m1$resp, m1.cold.preds, use='complete.obs', method='spearman'), error=function(e) NA)
    res$m1.s.cor.clip[m$iter] <- tryCatch(cor(test.m1$resp, m1.cold.preds.clip, use='complete.obs', method='spearman'), error=function(e) NA)
    if(verbose) {
      print(sprintf('Mode 1 cold RMSE: %.2f, clipped: %.2f', 
                    res$m1.RMSE[m$iter], res$m1.RMSE.clip[m$iter]))
      print(sprintf("Mode 1 cold explained variance: %.2f, clipped %.2f", 
                    res$m1.exp.var[m$iter], res$m1.exp.var.clip[m$iter]))
      print(sprintf("Mode 1 cold Pearson correlation: %.2f, clipped %.2f", 
                    res$m1.p.cor[m$iter], res$m1.p.cor.clip[m$iter]))
      print(sprintf("Mode 1 cold Spearman correlation: %.2f, clipped %.2f", 
                    res$m1.s.cor[m$iter], res$m1.s.cor.clip[m$iter]))
    }
  }
  
  if(length(test.m2))  if(sum(!is.na(test.m2$resp))) {
    m2.cold.preds <- test(d=test.m2, m=m)
    res$m2.RMSE[m$iter] <- nrmse(test.m2$resp, m2.cold.preds)
    m2.cold.preds.clip <- m2.cold.preds
    m2.cold.preds.clip[m2.cold.preds.clip < min(d$resp, na.rm=T)] <- min(d$resp, na.rm=T)
    m2.cold.preds.clip[m2.cold.preds.clip > max(d$resp, na.rm=T)] <- max(d$resp, na.rm=T)
    res$m2.RMSE.clip[m$iter] <- nrmse(test.m2$resp, m2.cold.preds.clip)
    res$m2.exp.var[m$iter] <- exp_var(test.m2$resp, m2.cold.preds)
    res$m2.exp.var.clip[m$iter] <- exp_var(test.m2$resp, m2.cold.preds.clip)
    res$m2.p.cor[m$iter] <- tryCatch(cor(test.m2$resp, m2.cold.preds, use='complete.obs'), error=function(e) NA)
    res$m2.p.cor.clip[m$iter] <- tryCatch(cor(test.m2$resp, m2.cold.preds.clip, use='complete.obs'), error=function(e) NA)
    res$m2.s.cor[m$iter] <- tryCatch(cor(test.m2$resp, m2.cold.preds, use='complete.obs', method='spearman'), error=function(e) NA)
    res$m2.s.cor.clip[m$iter] <- tryCatch(cor(test.m2$resp, m2.cold.preds.clip, use='complete.obs', method='spearman'), error=function(e) NA)
    if(verbose) {
      print(sprintf('Mode 2 cold RMSE: %.2f, clipped: %.2f', 
                    res$m2.RMSE[m$iter], res$m2.RMSE.clip[m$iter]))
      print(sprintf("Mode 2 cold explained variance: %.2f, clipped %.2f", 
                    res$m2.exp.var[m$iter], res$m2.exp.var.clip[m$iter]))
      print(sprintf("Mode 2 cold Pearson correlation: %.2f, clipped %.2f", 
                    res$m2.p.cor[m$iter], res$m2.p.cor.clip[m$iter]))
      print(sprintf("Mode 2 cold Spearman correlation: %.2f, clipped %.2f", 
                    res$m2.s.cor[m$iter], res$m2.s.cor.clip[m$iter]))
    }
  }

  if(length(test.m3)) if(sum(!is.na(test.m3$resp))) {
    m3.cold.preds <- test(d=test.m3, m=m)
    res$m3.RMSE[m$iter] <- nrmse(test.m3$resp, m3.cold.preds)
    m3.cold.preds.clip <- m3.cold.preds
    m3.cold.preds.clip[m3.cold.preds.clip < min(d$resp, na.rm=T)] <- min(d$resp, na.rm=T)
    m3.cold.preds.clip[m3.cold.preds.clip > max(d$resp, na.rm=T)] <- max(d$resp, na.rm=T)
    res$m3.RMSE.clip[m$iter] <- nrmse(test.m3$resp, m3.cold.preds.clip)
    res$m3.exp.var[m$iter] <- exp_var(test.m3$resp, m3.cold.preds)
    res$m3.exp.var.clip[m$iter] <- exp_var(test.m3$resp, m3.cold.preds.clip)
    res$m3.p.cor[m$iter] <- tryCatch(cor(test.m3$resp, m3.cold.preds, use='complete.obs'), error=function(e) NA)
    res$m3.p.cor.clip[m$iter] <- tryCatch(cor(test.m3$resp, m3.cold.preds.clip, use='complete.obs'), error=function(e) NA)
    res$m3.s.cor[m$iter] <- tryCatch(cor(test.m3$resp, m3.cold.preds, use='complete.obs', method='spearman'), error=function(e) NA)
    res$m3.s.cor.clip[m$iter] <- tryCatch(cor(test.m3$resp, m3.cold.preds.clip, use='complete.obs', method='spearman'), error=function(e) NA)
    if(verbose) {
      print(sprintf('Mode 3 cold RMSE: %.2f, clipped: %.2f', 
                    res$m3.RMSE[m$iter], res$m3.RMSE.clip[m$iter]))
      print(sprintf("Mode 3 cold explained variance: %.2f, clipped %.2f", 
                    res$m3.exp.var[m$iter], res$m3.exp.var.clip[m$iter]))
      print(sprintf("Mode 3 cold Pearson correlation: %.2f, clipped %.2f", 
                    res$m3.p.cor[m$iter], res$m3.p.cor.clip[m$iter]))
      print(sprintf("Mode 3 cold Spearman correlation: %.2f, clipped %.2f", 
                    res$m3.s.cor[m$iter], res$m3.s.cor.clip[m$iter]))
    }
  }

  if(length(test.m1m2)) if(sum(!is.na(test.m1m2$resp))) {
    m1m2.cold.preds <- test(d=test.m1m2, m=m)
    res$m1m2.RMSE[m$iter] <- nrmse(test.m1m2$resp, m1m2.cold.preds)
    m1m2.cold.preds.clip <- m1m2.cold.preds
    m1m2.cold.preds.clip[m1m2.cold.preds.clip < min(d$resp, na.rm=T)] <- min(d$resp, na.rm=T)
    m1m2.cold.preds.clip[m1m2.cold.preds.clip > max(d$resp, na.rm=T)] <- max(d$resp, na.rm=T)
    res$m1m2.RMSE.clip[m$iter] <- nrmse(test.m1m2$resp, m1m2.cold.preds.clip)
    res$m1m2.exp.var[m$iter] <- exp_var(test.m1m2$resp, m1m2.cold.preds)
    res$m1m2.exp.var.clip[m$iter] <- exp_var(test.m1m2$resp, m1m2.cold.preds.clip)
    res$m1m2.p.cor[m$iter] <- tryCatch(cor(test.m1m2$resp, m1m2.cold.preds, use='complete.obs'), error=function(e) NA)
    res$m1m2.p.cor.clip[m$iter] <- tryCatch(cor(test.m1m2$resp, m1m2.cold.preds.clip, use='complete.obs'), error=function(e) NA)
    res$m1m2.s.cor[m$iter] <- tryCatch(cor(test.m1m2$resp, m1m2.cold.preds, use='complete.obs', method='spearman'), error=function(e) NA)
    res$m1m2.s.cor.clip[m$iter] <- tryCatch(cor(test.m1m2$resp, m1m2.cold.preds.clip, use='complete.obs', method='spearman'), error=function(e) NA)
    if(verbose) {
      print(sprintf('Mode 1 & 2 cold RMSE: %.2f, clipped: %.2f', 
                    res$m1m2.RMSE[m$iter], res$m1m2.RMSE.clip[m$iter]))
      print(sprintf("Mode 1 & 2 cold explained variance: %.2f, clipped %.2f", 
                    res$m1m2.exp.var[m$iter], res$m1m2.exp.var.clip[m$iter]))
      print(sprintf("Mode 1 & 2 cold Pearson correlation: %.2f, clipped %.2f", 
                    res$m1m2.p.cor[m$iter], res$m1m2.p.cor.clip[m$iter]))
      print(sprintf("Mode 1 & 2 cold Spearman correlation: %.2f, clipped %.2f", 
                    res$m1m2.s.cor[m$iter], res$m1m2.s.cor.clip[m$iter]))
    }
  }
  
  if(length(test.m1m3)) if(sum(!is.na(test.m1m3$resp))) {
    m1m3.cold.preds <- test(d=test.m1m3, m=m)
    res$m1m3.RMSE[m$iter] <- nrmse(test.m1m3$resp, m1m3.cold.preds)
    m1m3.cold.preds.clip <- m1m3.cold.preds
    m1m3.cold.preds.clip[m1m3.cold.preds.clip < min(d$resp, na.rm=T)] <- min(d$resp, na.rm=T)
    m1m3.cold.preds.clip[m1m3.cold.preds.clip > max(d$resp, na.rm=T)] <- max(d$resp, na.rm=T)
    res$m1m3.RMSE.clip[m$iter] <- nrmse(test.m1m3$resp, m1m3.cold.preds.clip)
    res$m1m3.exp.var[m$iter] <- exp_var(test.m1m3$resp, m1m3.cold.preds)
    res$m1m3.exp.var.clip[m$iter] <- exp_var(test.m1m3$resp, m1m3.cold.preds.clip)
    res$m1m3.p.cor[m$iter] <- tryCatch(cor(test.m1m3$resp, m1m3.cold.preds, use='complete.obs'), error=function(e) NA)
    res$m1m3.p.cor.clip[m$iter] <- tryCatch(cor(test.m1m3$resp, m1m3.cold.preds.clip, use='complete.obs'), error=function(e) NA)
    res$m1m3.s.cor[m$iter] <- tryCatch(cor(test.m1m3$resp, m1m3.cold.preds, use='complete.obs', method='spearman'), error=function(e) NA)
    res$m1m3.s.cor.clip[m$iter] <- tryCatch(cor(test.m1m3$resp, m1m3.cold.preds.clip, use='complete.obs', method='spearman'), error=function(e) NA)
    if(verbose) {
      print(sprintf('Mode 1 & 3 cold RMSE: %.2f, clipped: %.2f', 
                    res$m1m3.RMSE[m$iter], res$m1m3.RMSE.clip[m$iter]))
      print(sprintf("Mode 1 & 3 cold explained variance: %.2f, clipped %.2f", 
                    res$m1m3.exp.var[m$iter], res$m1m3.exp.var.clip[m$iter]))
      print(sprintf("Mode 1 & 3 cold Pearson correlation: %.2f, clipped %.2f", 
                    res$m1m3.p.cor[m$iter], res$m1m3.p.cor.clip[m$iter]))
      print(sprintf("Mode 1 & 3 cold Spearman correlation: %.2f, clipped %.2f", 
                    res$m1m3.s.cor[m$iter], res$m1m3.s.cor.clip[m$iter]))
    }
  }
  
  if(length(test.m2m3)) if(sum(!is.na(test.m2m3$resp))) {
    m2m3.cold.preds <- test(d=test.m2m3, m=m)
    res$m2m3.RMSE[m$iter] <- nrmse(test.m2m3$resp, m2m3.cold.preds)
    m2m3.cold.preds.clip <- m2m3.cold.preds
    m2m3.cold.preds.clip[m2m3.cold.preds.clip < min(d$resp, na.rm=T)] <- min(d$resp, na.rm=T)
    m2m3.cold.preds.clip[m2m3.cold.preds.clip > max(d$resp, na.rm=T)] <- max(d$resp, na.rm=T)
    res$m2m3.RMSE.clip[m$iter] <- nrmse(test.m2m3$resp, m2m3.cold.preds.clip)
    res$m2m3.exp.var[m$iter] <- exp_var(test.m2m3$resp, m2m3.cold.preds)
    res$m2m3.exp.var.clip[m$iter] <- exp_var(test.m2m3$resp, m2m3.cold.preds.clip)
    res$m2m3.p.cor[m$iter] <- tryCatch(cor(test.m2m3$resp, m2m3.cold.preds, use='complete.obs'), error=function(e) NA)
    res$m2m3.p.cor.clip[m$iter] <- tryCatch(cor(test.m2m3$resp, m2m3.cold.preds.clip, use='complete.obs'), error=function(e) NA)
    res$m2m3.s.cor[m$iter] <- tryCatch(cor(test.m2m3$resp, m2m3.cold.preds, use='complete.obs', method='spearman'), error=function(e) NA)
    res$m2m3.s.cor.clip[m$iter] <- tryCatch(cor(test.m2m3$resp, m2m3.cold.preds.clip, use='complete.obs', method='spearman'), error=function(e) NA)
    if(verbose) {
      print(sprintf('Mode 2 & 3 cold RMSE: %.2f, clipped: %.2f', 
                    res$m2m3.RMSE[m$iter], res$m2m3.RMSE.clip[m$iter]))
      print(sprintf("Mode 2 & 3 cold explained variance: %.2f, clipped %.2f", 
                    res$m2m3.exp.var[m$iter], res$m2m3.exp.var.clip[m$iter]))
      print(sprintf("Mode 2 & 3 cold Pearson correlation: %.2f, clipped %.2f", 
                    res$m2m3.p.cor[m$iter], res$m2m3.p.cor.clip[m$iter]))
      print(sprintf("Mode 2 & 3 cold Spearman correlation: %.2f, clipped %.2f", 
                    res$m2m3.s.cor[m$iter], res$m2m3.s.cor.clip[m$iter]))
    }
  }
  
  if(length(test.m1m2m3)) if(sum(!is.na(test.m1m2m3$resp))) {
    m1m2m3.cold.preds <- test(d=test.m1m2m3, m=m)
    res$m1m2m3.RMSE[m$iter] <- nrmse(test.m1m2m3$resp, m1m2m3.cold.preds)
    m1m2m3.cold.preds.clip <- m1m2m3.cold.preds
    m1m2m3.cold.preds.clip[m1m2m3.cold.preds.clip < min(d$resp, na.rm=T)] <- min(d$resp, na.rm=T)
    m1m2m3.cold.preds.clip[m1m2m3.cold.preds.clip > max(d$resp, na.rm=T)] <- max(d$resp, na.rm=T)
    res$m1m2m3.RMSE.clip[m$iter] <- nrmse(test.m1m2m3$resp, m1m2m3.cold.preds.clip)
    res$m1m2m3.exp.var[m$iter] <- exp_var(test.m1m2m3$resp, m1m2m3.cold.preds)
    res$m1m2m3.exp.var.clip[m$iter] <- exp_var(test.m1m2m3$resp, m1m2m3.cold.preds.clip)
    res$m1m2m3.p.cor[m$iter] <- tryCatch(cor(test.m1m2m3$resp, m1m2m3.cold.preds, use='complete.obs'), error=function(e) NA)
    res$m1m2m3.p.cor.clip[m$iter] <- tryCatch(cor(test.m1m2m3$resp, m1m2m3.cold.preds.clip, use='complete.obs'), error=function(e) NA)
    res$m1m2m3.s.cor[m$iter] <- tryCatch(cor(test.m1m2m3$resp, m1m2m3.cold.preds, use='complete.obs', method='spearman'), error=function(e) NA)
    res$m1m2m3.s.cor.clip[m$iter] <- tryCatch(cor(test.m1m2m3$resp, m1m2m3.cold.preds.clip, use='complete.obs', method='spearman'), error=function(e) NA)
    if(verbose) {
      print(sprintf('Mode 1, 2 & 3 cold RMSE: %.2f, clipped: %.2f', 
                    res$m1m2m3.RMSE[m$iter], res$m1m2m3.RMSE.clip[m$iter]))
      print(sprintf("Mode 1, 2 & 3 cold explained variance: %.2f, clipped %.2f", 
                    res$m1m2m3.exp.var[m$iter], res$m1m2m3.exp.var.clip[m$iter]))
      print(sprintf("Mode 1, 2 & 3 cold Pearson correlation: %.2f, clipped %.2f", 
                    res$m1m2m3.p.cor[m$iter], res$m1m2m3.p.cor.clip[m$iter]))
      print(sprintf("Mode 1, 2 & 3 cold Spearman correlation: %.2f, clipped %.2f", 
                    res$m1m2m3.s.cor[m$iter], res$m1m2m3.s.cor.clip[m$iter]))
    }
  }
  return(res)
}

Try the BaTFLED3D package in your browser

Any scripts or data that you put into this service are public.

BaTFLED3D documentation built on May 2, 2019, 2:38 p.m.