working constraint classes

Author: grlloyd

DESCRIPTION

@@ -32,13 +32,14 @@ Collate:
     'struct_class.R'
     'parameter_class.R'
     'chart_class.R'
-    'stato_class.R'
+    'output_class.R'
     'DatasetExperiment_class.R'
+    'constraint_class.R'
     'entity_class.R'
+    'stato_class.R'
     'entity_stato_class.R'
     'enum_class.R'
     'enum_stato_class.R'
-    'output_class.R'
     'model_class.R'
     'example_objects.R'
     'model_list_class.R'
@@ -50,7 +51,7 @@ Collate:
     'struct-package.R'
     'struct_templates.R'
     'zzz.R'
-RoxygenNote: 7.3.1
+RoxygenNote: 7.3.2
 Depends: R (>= 4.0)
 Suggests: 
  testthat,

R/DatasetExperiment_class.R

@@ -2,18 +2,18 @@
 #'
 #' An object for holding raw data and associated meta data
 #'
-#' The DatasetExperiment object is an extension of the SummarizedExperiment object 
-#' from the SummarizedExperiment package (found on Bioconductor). 
-#' It incorporates the basic functionality of struct objects, containing fields such as 
+#' The DatasetExperiment object is an extension of the SummarizedExperiment object
+#' from the SummarizedExperiment package (found on Bioconductor).
+#' It incorporates the basic functionality of struct objects, containing fields such as
 #' Description, Name and Type with features of SummarizedExperiment such as subsetting.
-#' 
+#'
 #' There are some important differences between DatasetExperiment and SummarizedExperiment:
 #' \itemize{
 #' \item In DatasetExperiment data is stored as Samples (rows) x Features (columns)
 #' \item DatasetExperiment currently only supports a single assay
 #' \item length(DatasetExperiment) returns the number of samples
 #' }
-#'  
+#'
 #' @export
 #' @slot name Name of the dataset
 #' @slot description Brief description of the dataset
@@ -27,31 +27,31 @@
 #' @param ... named slot values to pass through to struct_class
 #' @import SummarizedExperiment
 #' @import S4Vectors
-#' @include generics.R struct_class.R stato_class.R chart_class.R
+#' @include generics.R struct_class.R output_class.R parameter_class.R chart_class.R
 #' @return DatasetExperiment
 #' @rdname struct_DatasetExperiment
 DatasetExperiment = function(
   data=data.frame(),
   sample_meta=data.frame(),
   variable_meta=data.frame(),
   ...){
-  
+
   # convert data set to list
   assays=list(data)
-  
+
   # sample_meta
-  
+
   out=.DatasetExperiment(SummarizedExperiment(
     assays=assays,
     colData=variable_meta,
     rowData=sample_meta),
     ...)
-  
+
   return(out)
 }
 
 .DatasetExperiment <- setClass(
-  "DatasetExperiment", 
+  "DatasetExperiment",
   contains = c("struct_class","SummarizedExperiment"),
   prototype=list('libraries'='SummarizedExperiment')
 )
@@ -61,9 +61,9 @@ DatasetExperiment = function(
 setMethod(f = "$",
   signature = c("DatasetExperiment"),
   definition = function(x,name) {
-    
+
     s = c('data','sample_meta','variable_meta')
-    
+
     if (name %in% s) {
       if (name == 'data') {
         if (length(assays(x))==0) {
@@ -72,23 +72,23 @@ setMethod(f = "$",
           value = assay(x,1)
         }
       } else if (name == 'sample_meta') {
-        value = S4Vectors::DataFrame(rowData(x),check.names = FALSE) 
+        value = S4Vectors::DataFrame(rowData(x),check.names = FALSE)
       } else if (name == 'variable_meta') {
         value = S4Vectors::DataFrame(colData(x),check.names = FALSE)
-      } 
-      
+      }
+
       if (name %in% s) {
         # convert to data.frame if using the original struct definitions
         value=as.data.frame(value)
       }
-      
+
       return(value)
-      
+
     } else {
       # for name,description etc
       return(callNextMethod())
     }
-    
+
   }
 )
 
@@ -117,10 +117,10 @@ setMethod(f = "$<-",
 setMethod(f = 'show',
   signature = c('DatasetExperiment'),
   definition = function(object) {
-    
+
     # print struct generic info
     callNextMethod()
-    
+
     # number of assays
     nms <- length(assays(object))
     if (is.null(nms)) {
@@ -135,8 +135,8 @@ setMethod(f = 'show',
 )
 
 #' Convert a DatasetExperiment to SummarizedExperiment
-#' 
-#' Converts a DatasetExperiment to SummarizedExperiment. The assay data is 
+#'
+#' Converts a DatasetExperiment to SummarizedExperiment. The assay data is
 #' transposed, and colData and rowData switched to match. struct specific
 #' slots such as "name" and "description" are stored in the metaData.
 #' @param obj a DatasetExperiment object
@@ -155,16 +155,16 @@ setMethod (f = 'as.SummarizedExperiment',
         'type'=obj$type,
         'libraries'=obj$libraries)
     )
-    
+
     return(out)
   }
 )
 
 
 #' Convert a SummarizedExperiment to DatasetExperiment
-#' 
-#' The assay data is transposed, and colData and rowData switched to match. 
-#' struct specific slots such as "name" and "description" are extracted from the 
+#'
+#' The assay data is transposed, and colData and rowData switched to match.
+#' struct specific slots such as "name" and "description" are extracted from the
 #' metaData if available. NB Any additional metadata will be lost during this conversion.
 #' @param obj a SummarizedExperiment object
 #' @return a DatasetExperiment object
@@ -177,7 +177,7 @@ setMethod (f = 'as.DatasetExperiment',
     B = as.data.frame(t(A))
     colnames(B) = rownames(A)
     rownames(B) = colnames(A)
-    
+
     out=DatasetExperiment(
       data=B,
       variable_meta=as.data.frame(rowData(obj)),
@@ -187,15 +187,15 @@ setMethod (f = 'as.DatasetExperiment',
       type=as.character(metadata(obj)$type),
       libraries=as.character(metadata(obj)$libraries)
     )
-    
+
     return(out)
   }
 )
 
 
 
 #' Export a dataset to an excel file
-#' 
+#'
 #' Exports a dataset object to an excel file with sheets for data, sample_meta and variable_meta
 #' @param object a dataset object
 #' @param outfile the filename (including path) to write the data to
@@ -211,19 +211,19 @@ setMethod (f = 'as.DatasetExperiment',
 setMethod(f = "export_xlsx",
   signature = c("DatasetExperiment"),
   definition = function(object,outfile,transpose = TRUE) {
-    
+
     # check for openxlsx
     if (!requireNamespace('openxlsx', quietly = TRUE)) {
       stop('package "openxlsx" was not found. Please install it to use "export.xlsx()".')
     }
-    
-    
+
+
     if (transpose) {
       X = as.data.frame(t(object$data))
     } else {
       X = object$data
     }
-    
+
     OUT = list(
       'data' = X,
       'sample_meta' = object$sample_meta,
@@ -242,7 +242,7 @@ setMethod(f = "export_xlsx",
     return(IN)
 }
 
-#' @export 
+#' @export
 #' @rdname autocompletion
 setMethod('.DollarNames','DatasetExperiment',.DollarNames.DatasetExperiment)
 

R/constraint_class.R

@@ -0,0 +1,76 @@
+#' @include generics.R struct_class.R parameter_class.R output_class.R
+
+# Define the entity_constraint class
+setClass("entity_constraint",
+         contains = 'struct_class',
+         slots = c(
+             message = "function",
+             test = "function"))
+
+# Define the generic function for validation
+setGeneric("check_constraints", function(entity_constraint, object) {
+    standardGeneric("check_constraints")
+})
+
+# Define the method for the entity_constraint class
+setMethod("check_constraints", "entity_constraint", function(entity_constraint, object) {
+    # check validity
+    valid = entity_constraint@test(object)
+
+    # return error msg if not valid
+    if (!valid) {
+        valid = entity_constraint@message(object)
+    }
+
+    # return TRUE if valid, otherwise returns message
+    return(valid)
+
+})
+
+# Define specific entity_constraints as instances of the entity_constraint class
+constraint.max_len <- function() {
+    new_struct("entity_constraint",
+        name = 'Maximum length constraint',
+        description = paste0('Checks that the value of an entity object not longer than specified.'),
+        message = function(object){
+            msg = c(paste0('entity$name = ',object$name),
+                    paste0('entity$value must be at least ', min_value))
+            return(msg)
+        },
+        test = function(object) {
+            check = length(object@value) <= object@max_length
+            return(check)
+        })
+}
+
+constraint.type <- function() {
+    new_struct("entity_constraint",
+        name = 'Type constraint',
+        description = 'Checks that the value of an entity object is of the expected type.',
+        message = function(object){
+            msg = c(paste0('entity$name = ',object$name),
+                    paste0('entity$value must be of type ', object$type))
+            return(msg)
+        },
+        test = function(object) {
+            check = any(sapply(object@type, function(t) is(object@value, t)))
+            return(check)
+        })
+}
+
+
+# test for minimum
+constraint.min_value <- function(min_value) {
+    new_struct("entity_constraint",
+        name = 'Minimum value constraint',
+        description = paste0('Checks that the value of an entity object not less than ',min_value),
+        message = paste("Minimum value must be at least", min_value),
+        test = function(object) {
+            if (any(object@value < min_value)) {
+                msg = c(paste0('entity$name = ',object$name),
+                        paste0('entity$value must be at least ', min_value))
+                return(msg)
+            }
+            return(TRUE)
+        })
+}