R/lsANOVA.R

In Losses/ls4pR: A package for psychology studies

#' lsANOVA
#'
#' Class to describe available F test result.
#' @param x (data.frame) The dataset to be processed.
#' @param factors (character) The columns to be trated be factors.
#' @param marks (character) The columns to be trated be marks.
#' @param max_p (numeric, default: 0.05) The max p.value of F test.
#' @param min_bartlett (numeric, default: 0.1) The min p.value of bartlett test.
#' @return (lsANOVA) An object include the acceptable F test.
#' @importFrom methods setRefClass
#' @author Losses Don
#' @keywords ANOVA
#' @export

setRefClass(
  'lsANOVA',
  fields = list(
    call = 'call',
    factors = 'character',
    marks = 'character',
    min_bartlett = 'numeric',
    max_p = 'numeric',
    bartlett.p = 'matrix',
    p.value = 'matrix',
    f.test = 'matrix',
    acceptable_f = 'matrix',
    acceptable_p = 'matrix'
  ),
  methods = list(
    initialize = function(x = NA_real_, factors = NA_real_, marks = NA_real_, max_p = 0.05, min_bartlett = 0.1){
      'Calculate the acceptable F test result.'

      #get all the p value, F test result and bartlett test result.
      bartlett_p <- p_value <- f_test <- matrix(0, ncol = length(factors), nrow = length(marks), dimnames = list(marks, factors))

      for (.i in factors){
        for (.j in marks){
          .anova_sample <- x[,c(.i, .j)]

          .anova_summary <- as.data.frame(table(.anova_sample[, .i]))
          .anova_abnormal <- .anova_summary[which(.anova_summary$Freq == 1), 'Var1']

          if (length(.anova_abnormal) != 0)
            .anova_sample <- .anova_sample[!.anova_sample[, .i] %in% .anova_abnormal, ]

          p <- bartlett.test(.anova_sample[,.j] ~ factor(.anova_sample[,.i]))$p.value
          bartlett_p[.j, .i] <- p

          module <- aov(.anova_sample[,.j] ~ factor(.anova_sample[,.i]))
          aov.summary <- summary(module)[[1]]
          pr <- aov.summary$`Pr(>F)`[1]
          f <- aov.summary$`F value`[1]
          p_value[.j, .i] <- pr
          f_test[.j, .i] <- f
        }
      }

      #Sort out the acceptable F test result.
      unacceptable_condition <- p_value >= max_p | bartlett_p <= min_bartlett
      .acceptable_f <- f_test
      .acceptable_f[unacceptable_condition] <- NA

      .acceptable_p <- p_value
      .acceptable_p[unacceptable_condition] <- NA

      p.value <<- p_value
      f.test <<- f_test
      bartlett.p <<- bartlett_p
      acceptable_f <<- .acceptable_f
      acceptable_p <<- .acceptable_p
      call <<- substitute(x)
    },

    show = function(...){
      cat('\nAvailable F Test Result:\n\n')
      print(acceptable_f, na.print = '-', ...)
    }
  )
)

#' lsANOVARead
#'
#' Get the description of the ANOVA result.
#' @param x (lsANOVA) The object generated by lsANOVA.
#' @return (lsANOVARead) An object include the description of acceptable F test.
#' @note While using print function, you can add a param 'round = F' to show the full result of description (holy long).
#' @author Losses Don
#' @keywords ANOVA
#' @importFrom psych describeBy
#' @export

setRefClass(
  'lsANOVARead',
  fields = list(
    call = 'name',
    read_result = 'list',
    mixed_result = 'list'
  ),
  method = list(
    initialize = function(x = NA_real_){
      'generate the detail information of each group devided by acceptable ANOVA result.'
      if (class(x) != 'lsANOVA') stop('x must be a lsANOVA object.')

      result <- list()
      data <- eval(x$call)

      for (.factor in colnames(x$p.value)){
        available_status <- !is.na(x$acceptable_f[,.factor])
        .this_table <- table(available_status)
        if (!("TRUE" %in% names(.this_table))) next
        .this_describe <- describeBy(x = data[,rownames(x$p.value)[available_status]], group = factor(data[, .factor]))

        for (.i in names(.this_describe)) rownames(.this_describe[[.i]]) <- rownames(x$p.value)[available_status]

        result[[.factor]] <- .this_describe
      }

      read_result <<- result
      call <<- substitute(x)

      # mix all the result
      for (.factor in names(result)){
        this_factor <- result[[.factor]]
        mix_result <- this_factor[[1]][0, ]

        group_sn <- 0
        for (.group in names(this_factor)){
          group_sn <- group_sn + 1
          group <- .group

          mark <- rownames(this_factor[[.group]])
          rownames(this_factor[[.group]]) <- NULL

          this_group <- cbind(mark, group,  this_factor[[.group]], group_sn)
          mix_result <- rbind(mix_result, this_group)
        }

        mix_result <- mix_result[order(mark[mix_result$mark], mix_result$group_sn), ]

        mark_type <- unique(as.character(mix_result$mark))
        group_per_mark <- length(mix_result$mark) / length(mark_type)
        mark <- p <- f <- c()

        for (.mark in mark_type){
          this_mark <- character(group_per_mark)
          this_mark[1] <- .mark
          mark <- c(mark, this_mark)
        }

        for (.f in na.omit(x$acceptable_f[, .factor])){
          this_f <- character(group_per_mark)
          this_f[1] <- .f
          f <- c(f, this_f)
        }

        for (.p in na.omit(x$acceptable_p[, .factor])){
          this_p <- character(group_per_mark)
          this_p[1] <- .p
          p <- c(p, this_p)
        }

        mix_result <- mix_result[, -match('mark', colnames(mix_result))]
        mix_result <- cbind(mark, f, p, mix_result)
        mix_result <- mix_result[, -match(c('vars', 'group_sn'), colnames(mix_result))]
        rownames(mix_result) <- NULL

        result[[.factor]] <- mix_result
      }

      mixed_result <<- result
    },

    show = function(round = T){
      cat('\nRead Result of lsANOVA Object\n')
      cat('=============================\n')

      temp_result <- mixed_result
      for (.factor in names(temp_result)){
        cat('\n\n* Data grouped by the factor: ')
        cat(.factor)
        cat('\n\n')

        if (round){
          for (.colname in c('f', 'p')){
            temp_result[[.factor]][,.colname] <- sprintf('%.4f',as.numeric(as.character(temp_result[[.factor]][,.colname])))
            temp_result[[.factor]][,.colname][temp_result[[.factor]][,.colname] == 'NA'] <- ''
          }

          for (.colname in c('mean', 'sd', 'trimmed', 'mad', 'skew', 'kurtosis', 'se'))
            temp_result[[.factor]][,.colname] <- round(temp_result[[.factor]][,.colname], 3)
        }

        print(temp_result[[.factor]], row.names = FALSE)
      }
    }
  )
)

#' lsANOVA
#'
#' Generate a lsANOVA Object.
#' @param ... params to pass to lsANOVA object.
#' @return (lsANOVA) An object include the acceptable F test.
#' @note See lsANOVA-class.
#' @author Losses Don
#' @keywords ANOVA
#' @export
lsANOVA <- function(...){
  new("lsANOVA", ...)
}

#' lsANOVA.read
#'
#' Generate a lsANOVARead Object.
#' @param ... params to pass to lsANOVARead object.
#' @return (lsANOVARead) An object include the description of acceptable F test.
#' @note See lsANOVARead-class.
#' @author Losses Don
#' @keywords ANOVA
#' @export
lsANOVA.read <- function(...){
  new("lsANOVARead", ...)
}

#' @export
print.lsANOVA <- function(x, ...){
  x$show(...)

  invisible(x)
}

#' @export
print.lsANOVARead <- function(x, ...){
  x$show(...)

  invisible(x)
}