R/generates_transformation_functions.R

In okayaa/MTSYS: Methods in Mahalanobis-Taguchi (MT) System

#' Function to generate data transformation functions for the T1 methods
#'
#' \code{generates_transformation_functions_T1} is the argument for the
#'   parameter \code{generates_transform_functions} in \code{genera_T}, which
#'   is used in the T1 method. In addtion, the Ta method also uses this function
#'   for the argument.
#'
#' @param unit_space_data Matrix with n rows (samples) and (p + 1) columns
#'                          (variables). Data to generate the unit space. All
#'                          data should be continuous values and should not have
#'                          missing values.
#'
#' @return \code{generates_transformation_functions_T1} returns a list
#'           containing three functions. For the first component, the data
#'           transformation function for independent variables is a function
#'           that subtracts the mean of each independent variable. For the
#'           second component, the data transformation function for a dependent
#'           variable is a function that subtracts the mean of a dependent
#'           variable. For the third component, the inverse function of the data
#'           transformation function for a dependent variable is a function that
#'           adds the mean of a dependent variable. The mean used is the mean of
#'           the \code{unit_space_data}.
#'
#' @seealso \code{\link{T1}} and \code{\link{Ta}}
#'
#' @examples
#' # The value of the dependent variable of the following samples mediates
#' # in the stackloss dataset.
#' stackloss_center <- stackloss[c(9, 10, 11, 20, 21), ]
#'
#' tmp <- generates_transformation_functions_T1(stackloss_center)
#' mean_subtraction_function <- tmp[[1]]
#' subtracts_M_0 <- tmp[[2]]
#' adds_M_0 <- tmp[[3]]
#'
#' is.function(mean_subtraction_function) # TRUE
#' is.function(subtracts_M_0) # TRUE
#' is.function(adds_M_0) # TRUE
#'
#' @export
generates_transformation_functions_T1 <- function(unit_space_data) {

  center <- apply(unit_space_data, 2, mean)
  unit_space_center <- center[-length(center)]
  M_0 <- center[length(center)]

  subtracts_mean <-
         generates_normalization_function(unit_space_center = unit_space_center,
                                          is_scaled = FALSE)

  subtracts_M_0 <- function(x) x - M_0

  adds_M_0 <- function(x) x + M_0

  return(list(subtracts_mean, subtracts_M_0, adds_M_0))

}


#' Function to generate data transformation functions for the Tb methods
#'
#' \code{generates_transformation_functions_Tb} is the argument for the
#'   parameter \code{generates_transform_functions} in \code{genera_T}, which
#'   is used in the Tb method.
#'
#' @param sample_data Matrix with n rows (samples) and (p + 1) columns
#'                      (variables). The Tb method uses all data to generate the
#'                      unit space. All data should be continuous values and
#'                      should not have missing values.
#' @param subtracts_V_e If \code{TRUE}, then the error variance is subtracted in
#'                        the numerator when calculating \code{eta_hat}.
#'
#' @return \code{generates_transformation_functions_Tb} returns a list
#'           containing three functions. For the first component, the data
#'           transformation function for independent variables is a function
#'           that subtracts the center of each independent variable. The center
#'           is determined in a specific manner for the Tb method. The center
#'           consists of each sample value which maximizes the signal-to-noise
#'           ratio (S/N) per independent variable. The values are determined
#'           independently so that different samples may be selected for
#'           different variables. For the second component, the data
#'           transformation function for a dependent variable is a function that
#'           subtracts the dependent variable of the sample which maximizes the
#'           S/N per independent variable. For the third component, the inverse
#'           function of the data transformation function for a dependent
#'           variable is a function that adds the weighted mean of a dependent
#'           variable. The weighted mean is calculated based on the S/N and the
#'           frequency of being selected in independent variables.
#'
#' @references
#'   Inou, A., Nagata, Y., Horita, K., & Mori, A. (2012). Prediciton Accuracies
#'     of Improved Taguchi's T Methods Compared to those of Multiple Regresssion
#'     Analysis. \emph{Journal of the Japanese Society for Quality Control,
#'     42}(2), 103-115. (In Japanese)
#'
#'   Kawada, H., & Nagata, Y. (2015). An application of a generalized inverse
#'     regression estimator to Taguchi's T-Method. \emph{Total Quality Science,
#'     1}(1), 12-21.
#'
#' @seealso \code{\link{Tb}}
#'
#' @examples
#' # The value of the dependent variable of the following samples mediates
#' # in the stackloss dataset.
#' stackloss_center <- stackloss[c(9, 10, 11, 20, 21), ]
#'
#' tmp <- generates_transformation_functions_Tb(stackloss_center, TRUE)
#' center_subtraction_function <- tmp[[1]]
#' subtracts_ys <- tmp[[2]]
#' adds_M_0 <- tmp[[3]]
#'
#' is.function(center_subtraction_function) # TRUE
#' is.function(subtracts_ys) # TRUE
#' is.function(adds_M_0) # TRUE
#'
#' # Note that dynamic scope is used when the parameter "subtracts_V_e" is not
#' # set.
#' subtracts_V_e <- FALSE
#' tmp <- generates_transformation_functions_Tb(stackloss_center)
#' center_subtraction_function <- tmp[[1]]
#' subtracts_ys <- tmp[[2]]
#' adds_M_0 <- tmp[[3]]
#'
#' is.function(center_subtraction_function) # TRUE
#' is.function(subtracts_ys) # TRUE
#' is.function(adds_M_0) # TRUE
#'
#' @export
generates_transformation_functions_Tb <- function(sample_data, subtracts_V_e) {

  # Attention: Dynamic scope is used here.
  # To avoid, newly defining the wrapper function with a parameter
  # "subtracts_V_e" and passing the wrapper function to the argument
  # "generates_transform_functions" may be another solution.
  if (missing(subtracts_V_e)) {
    subtracts_V_e <- evalq(subtracts_V_e, parent.frame())
  }

  get_eta <- function(one_sample_data, all_sample_data, subtracts_V_e) {
    model <- general_T(unit_space_data = one_sample_data,
                       signal_space_data = all_sample_data,
                       generates_transform_functions =
                                          generates_transformation_functions_T1,
                       subtracts_V_e = subtracts_V_e,
                       includes_transformed_data = FALSE)

    return(model$eta_hat)

  }

  etas <- apply(sample_data, 1, get_eta, sample_data, subtracts_V_e)

  # apply per row (=1) because the rows and columns were transposed in above.
  max_eta_index <- apply(etas, 1, which.max)

  unit_space_center <-
                 diag(as.matrix(sample_data[max_eta_index, -ncol(sample_data)]))
  subtracts_center <-
         generates_normalization_function(unit_space_center = unit_space_center,
                                          is_scaled = FALSE)

  subtracts_ys <- function(x)
        sapply(sample_data[max_eta_index, ncol(sample_data)], function(y) x - y)

  max_eta <- diag(as.matrix(etas[, max_eta_index]))
  M_0 <-
     sum(max_eta / sum(max_eta) * sample_data[max_eta_index, ncol(sample_data)])
  adds_M_0 <- function(x) x + M_0

  return(list(subtracts_center, subtracts_ys, adds_M_0))

}