R/classification_dimension.R

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

#' Gets the description of a classification dimension
#' @param tableID ID of the table the dimension is of.
#' @param position The positioin of the dimension in the table
#' @param channel Connection to the Access database
#' @export

get_CD_description <- function(tableID, position, channel){
  stopifnot(as.integer(tableID) == tableID)  
  stopifnot(as.integer(position) == position)  
  x <- sqlQuery(channel, paste("select Description from TableClassDimDic where TableID = ", 
                               tableID, " and Position = ", position,  sep = ""))
  if (nrow(x) == 0){stop("Analysis dimension does not exist")}
  if (nrow(x) != 1){stop("More than one dimension matches given name")}
  return(as.character(x$Description[1]))
}

#' Gets the typeID of a classification dimension
#' @param tableID ID of the table the dimension is of.
#' @param position The positioin of the dimension in the table
#' @param channel Connection to the Access database
#' @export

get_CD_typeID <- function(tableID, position, channel){
  stopifnot(as.integer(tableID) == tableID)  
  stopifnot(as.integer(position) == position)  
  x <- sqlQuery(channel, paste("select TypeID from TableClassDimDic where TableID = ", 
                               tableID, " and Position = ", position,  sep = ""))
  if (nrow(x) == 0){stop("Analysis dimension does not exist")}
  if (nrow(x) != 1){stop("More than one dimension matches given name")}
  return(x$TypeID[1])
}

#' Gets the description table name for a given typeID
#' @param typeID ID of the type whose description is required
#' @param channel Connection to the Access database
#' @export

get_typeID_description_table_name <- function(typeID, channel){
  x <- sqlQuery(channel, paste("select DicID from TypeDic where TypeID = ", 
                               typeID,  sep = ""))
  if (nrow(x) == 0){stop("Type does not exist")}
  if (nrow(x) != 1){stop("More than one type matches given id")}
  x <- x$DicID[1]
  table_names <- list()
  table_names[[2]] <- "ClassificationDic"
  table_names[[3]] <- "RangeDic"
  table_names[[4]] <- "PartitionDic"
  return(table_names[[x]])
}

#' Gets the lookup table name for a given typeID
#' @param typeID ID of the type whose lookup table is required
#' @param channel Connection to the Access database
#' @export

get_typeID_lookup_table_name <- function(typeID, channel){
  x <- sqlQuery(channel, paste("select DicID from TypeDic where TypeID = ", 
                               typeID,  sep = ""))
  if (nrow(x) == 0){stop("Type does not exist")}
  if (nrow(x) != 1){stop("More than one type matches given id")}
  x <- x$DicID[1]
  table_names <- list()
  table_names[[2]] <- "ClassificationValueDic"
  table_names[[3]] <- "RangeValueDic"
  table_names[[4]] <- "PartitionIntervalDic"
  return(table_names[[x]])
}

#' Gets the lookup table for a given typeID
#' @param typeID ID of the type whose lookup table is required
#' @param channel Connection to the Access database
#' @export

get_typeID_lookup <- function(typeID, channel){
  lookup_table_name <- get_typeID_lookup_table_name(typeID, channel)
  x <- sqlQuery(channel, paste("SELECT * FROM ",
                               lookup_table_name, " WHERE TypeID = ",
                               typeID, sep = ""))  
  if (lookup_table_name == "ClassificationValueDic"){
    y <- (x[,c("EnumValue","Description")])
  } else if (lookup_table_name == "PartitionIntervalDic"){
    y <- (x[,c("Position","Description")])
  } else if (lookup_table_name == "RangeValueDic"){
    y <- (x[,c("Value","Value")])
  } else {
    stop("Lookup not supported")
  }
  names(y) <- c("value","label")
  if (class(y$label) == 'factor'){y$label <- as.character(y$label)}
  return(y)
}

#' The CDim Class
#' Describes a classification dimension
#' 
#' @rdname CDim
#' @aliases CDim-class
#' @exportClass CDim

.CDim <- setClass(
  Class = "CDim",
  representation = representation(
    tableID = 'numeric',
    position = 'numeric',
    description = 'character',
    typeID = 'numeric',
    lookup_table_name = 'character',
    lookup = 'data.frame'
  ),
  validity = function(object){
    if (object@tableID != as.integer(object@tableID)){
      stop('tableID must be an integer')
    }
    if (object@typeID != as.integer(object@typeID)){
      stop('typeID must be an integer')
    }
    if (object@position != as.integer(object@position)){
      stop('position must be an integer')
    }
    return(TRUE)
  }
)

#' Constructs a classification dimension object
#' @param tableID ID of the table the dimension is of.
#' @param position The positioin of the dimension in the table
#' @param channel Connection to the Access database
#' @export

new_ClassificationDimension <- function(tableID, position, channel){
  description <- get_CD_description(tableID, position, channel)
  typeID <- get_CD_typeID(tableID, position, channel)
  lookup_table_name <- get_typeID_lookup_table_name(typeID, channel)
  lookup <- get_typeID_lookup(typeID, channel)
  return(.CDim(tableID = tableID,
               position = position,
               description = description,
               typeID = typeID,
               lookup_table_name = lookup_table_name,
               lookup = lookup
               ))
}