R/modgen_table.R

In philliplab/modgenTester: Test and reporting for modgen models with R

#' @include classification_dimension.R
#' @include parameter_dimension.R
NULL

#' Loads the data of a table (or parameter) into R without performing any formatting
#' @param table_name The name of the table (or parameter) to load
#' @param channel A connection to the Access database
#' @export

get_raw_table <- function(table_name, channel){
  sqlQuery(channel, paste('SELECT * FROM ', table_name, sep = ''))
}

#' Get the tabeID for a given table from a given database
#' @param table_name The name of the table whose id is required
#' @param channel A connection to the Access database
#' @export

get_tableID <- function(table_name, channel){
  x <- sqlQuery(channel, paste("select TableID from TableDic where Name = '", table_name, "'", sep = ""))
  if (nrow(x) == 0){stop("No table matches given name")}
  if (nrow(x) > 1){stop("More than one table matches given name")}
  return(x$TableID[1])
}

#' Get the parameterID for a given parameter from a given database
#' @param parameter_name The name of the parameter whose id is required
#' @param channel A connection to the Access database
#' @export

get_parameterID <- function(parameter_name, channel){
  x <- sqlQuery(channel, paste("select ParameterID from ParameterDic where Name = '", parameter_name, "'", sep = ""))
  if (nrow(x) != 1){stop("More than one parameter matches given name")}
  return(x$ParameterID[1])
}

#' Get analysis dimension position for a given table from a given database
#' @param tableID The id of the table whose analysis dimension position is required
#' @param channel A connection to the Access database
#' @export

get_analysis_dimension_position <- function(tableID, channel){
  stopifnot(as.integer(tableID) == tableID)
  x <- sqlQuery(channel, 
                paste('select AnalysisDimensionPosition from TableDic where TableID = ', 
                      tableID, sep = ""))
  return(x$AnalysisDimensionPosition[1])
}

#' Get analysis dimension lookup for a given table from a given database
#' @param tableID The id of the table whose analysis dimension lookup is required
#' @param channel A connection to the Access database
#' @export

get_analysis_dimension_lookup <- function(tableID, channel){
  stopifnot(as.integer(tableID) == tableID)
  x <- sqlQuery(channel, 
                paste('select ExpressionID, Description from TableExpressionDic where TableID = ', 
                      tableID, sep = ""))
  names(x) <- c("value", "label")
  x$label <- as.character(x$label)
  return(x)
}

#' Gets the positions of the classification dimensions in a results table
#' @param tableID The id of the table whose analysis dimension lookup is required
#' @param channel A connection to the Access database
#' @export

get_classification_positions <- function(tableID, channel){
  positions <- sqlQuery(channel, paste("SELECT Position FROM TableClassDimDic where TableID = ", 
                                       tableID, sep = ""))
  return(positions$Position)
}

#' Gets the positions of the parameter dimensions in a parameter table
#' @param parameterID The id of the parameter whose dimension positions is required
#' @param channel A connection to the Access database
#' @export

get_parameter_dimension_positions <- function(parameterID, channel){
  positions <- sqlQuery(channel, paste("SELECT DisplayPosition FROM ParameterDimensionDic where ParameterID = ", 
                                       parameterID, sep = ""))
  return(positions$DisplayPosition)
}

#' The RTable Class
#' Contains a modgen result table and all its meta data
#' 
#' @rdname RTable
#' @aliases RTable-class
#' @exportClass RTable

.RTable <- setClass(
  Class = "RTable",
  representation = representation(
    raw_data = 'data.frame',
    tableID = 'numeric',
    table_name = 'character',
    analysis_dim_position = 'numeric',
    analysis_dim_lookup = 'data.frame',
    CDs = 'list'
  ),
  validity = function(object){
    if (object@tableID != as.integer(object@tableID)){
      stop('tableID must be an integer')
    }
    if (object@analysis_dim_position != as.integer(object@analysis_dim_position)){
      stop('typeID must be an integer')
    }
    if (length(object@CDs) > 0){
      if (!all(lapply(object@CDs, class) == 'CDim')){
        stop('Classification dimensions must be of class CDim')
      }
    }
    return(TRUE)
  }
)

#' Constructs a copy of a result table in R
#' @param table_name The name of the table to load
#' @param channel A connection to the Access database
#' @export

new_RTable <- function(table_name, channel){
  table_type <- 'result'
  raw_data <- get_raw_table(table_name, channel)
  tableID <- get_tableID(table_name, channel)
  analysis_dim_lookup <- get_analysis_dimension_lookup(tableID, channel)
  CDs <- list()
  positions <- get_classification_positions(tableID, channel)
  analysis_dim_position <- length(positions) + 1
  if (analysis_dim_position > 1){
    for (position in positions){
      CDs <- c(CDs, new_ClassificationDimension(tableID, position, channel))
    }
  }
  return(.RTable(raw_data = raw_data,
                 tableID = tableID,
                 analysis_dim_position = analysis_dim_position,
                 analysis_dim_lookup = analysis_dim_lookup,
                 CDs = CDs)) 
}

#' Returns an RTable as a fully formatted data.frame
#' 
#' It adds sensible column names and puts the labels on the classification dimension factors
#' @param x The RTable object to format
#' @export

as.data.frame.RTable <- function(x){
  raw_data <- x@raw_data
  names(raw_data)[x@analysis_dim_position] <- 'metrics'
  raw_data[,x@analysis_dim_position] <- x@analysis_dim_lookup$label[match(x@raw_data[,x@analysis_dim_position], 
                                                                          x@analysis_dim_lookup$value)]
  if (length(x@CDs) > 0){
    for (i in 1:length(x@CDs)){
      curr_cd <- x@CDs[[i]]
      names(raw_data)[curr_cd@position + 1] <- curr_cd@description
      raw_data <- raw_data[raw_data[,curr_cd@position + 1] %in% curr_cd@lookup$value,]
      raw_data[,curr_cd@position + 1] <- curr_cd@lookup$label[match(raw_data[,curr_cd@position + 1], 
                                                                    curr_cd@lookup$value)]
    }
  }
  return(raw_data)
}

#' The PTable Class
#' Contains a modgen parameter table and all its meta data
#' 
#' @rdname PTable
#' @aliases PTable-class
#' @exportClass PTable

.PTable <- setClass(
  Class = "PTable",
  representation = representation(
    raw_data = 'data.frame',
    parameterID = 'numeric',
    parameter_name = 'character',
    PDs = 'list'
  ),
  validity = function(object){
    if (object@parameterID != as.integer(object@parameterID)){
      stop('parameterID must be an integer')
    }
    if (length(object@PDs) > 0){
      if (!all(lapply(object@PDs, class) == 'PDim')){
        stop('Parameter dimensions must be of class PDim')
      }
    }
    return(TRUE)
  }
)

#' Constructs a copy of a parameter table in R
#' @param table_name The name of the table to load
#' @param channel A connection to the Access database
#' @export

new_PTable <- function(parameter_name, channel){
  raw_data <- get_raw_table(parameter_name, channel)
  parameterID <- get_parameterID(parameter_name, channel)
  PDs <- list()
  positions <- get_parameter_dimension_positions(parameterID, channel)
  if (length(positions) > 0){
    for (position in positions){
      PDs <- c(PDs, new_ParameterDimension(parameterID, position, channel))
    }
  }
  return(.PTable(parameter_name = parameter_name,
              raw_data = raw_data,
              parameterID = parameterID,
              PDs = PDs)) 
}

#' Returns an PTable as a fully formatted data.frame
#' 
#' It adds sensible column names and puts the labels on the classification dimension factors
#' @param x The PTable object to format
#' @export

as.data.frame.PTable <- function(x){
  raw_data <- x@raw_data
  if (length(x@PDs) > 0){
    for (i in 1:length(x@PDs)){
      curr_cd <- x@PDs[[i]]
      names(raw_data)[curr_cd@position + 1] <- curr_cd@description
      raw_data <- raw_data[raw_data[,curr_cd@position + 1] %in% curr_cd@lookup$value,]
      raw_data[,curr_cd@position + 1] <- curr_cd@lookup$label[match(raw_data[,curr_cd@position + 1], 
                                                                    curr_cd@lookup$value)]
    }
  }
  return(raw_data)
}