use tidy constraints

Author: grlloyd

DESCRIPTION

@@ -34,7 +34,6 @@ Collate:
     'chart_class.R'
     'output_class.R'
     'DatasetExperiment_class.R'
-    'constraint_class.R'
     'entity_class.R'
     'stato_class.R'
     'entity_stato_class.R'
@@ -65,5 +64,5 @@ Suggests:
 VignetteBuilder: knitr
 Imports: methods,ontologyIndex,
     datasets, graphics, stats, utils, knitr, 
-    SummarizedExperiment, S4Vectors, rols
+    SummarizedExperiment, S4Vectors, rols,rlang
 biocViews: WorkflowStep

NAMESPACE

@@ -26,6 +26,7 @@ export(chart_names)
 export(chart_plot)
 export(citations)
 export(entity)
+export(entity_constraint)
 export(entity_stato)
 export(enum)
 export(enum_stato)
@@ -147,6 +148,7 @@ import(S4Vectors)
 import(SummarizedExperiment)
 import(datasets)
 import(methods)
+import(rlang)
 importFrom(graphics,plot)
 importFrom(knitr,purl)
 importFrom(ontologyIndex,get_ontology)

R/constraint_class.R

@@ -10,12 +10,13 @@
 #' can be extracted using \code{param_obj} and \code{output_obj}.
 #'
 #' @export
+#' @import rlang
 #' @inheritParams struct_class
 #' @param obj An entity object
 #' @param max_length Maximum length of value vector (default 1)
 #' @param value The value of the parameter/outputs
 #' @param ... additional inputs to the struct_class object
-#' @include generics.R struct_class.R parameter_class.R constraint_class.R
+#' @include generics.R struct_class.R parameter_class.R
 #' @return An entity object
 #' @examples
 #' # Create a new entity object
@@ -31,16 +32,16 @@
 #' value(E) = 10
 #' @rdname entity
 entity = function(
-    name,
-    description=character(0),
-    type='character',
-    value=NULL,
-    max_length=Inf,
-    constraints=list(
-        constraint.type(),   # check type by default
-        constraint.max_len()  # check max length by default
-    ),
-    ...) {
+        name,
+        description=character(0),
+        type='character',
+        value=NULL,
+        max_length=Inf,
+        constraints=list(
+            type_equals,
+            maximum_length
+        ),
+        ...) {
 
     value=check_init_val(value,type)
 
@@ -67,27 +68,25 @@ entity = function(
         value = character(0),
         type = 'character',
         max_length = Inf,
-        ontology=character(),
-        constraints = list(
-            constraint.type(),   # check type by default
-            constraint.max_len()  # check max length by default
-        )
-    ),
+        ontology=character()),
     validity = function(object) {
 
-        # loop over all constraints
-        msg=character(0)
-        for (k in object@constraints) {
-            # test constraint
-            check = k@test(object)
+        msg = character(0)
+        for (k in object@constraints){
+            check = eval(k$ex,env=list2env(slots(object)))
             if (!check) {
-                msg=c(msg,k@message(object))
+                msg=c(
+                    msg,
+                    paste0('Entity "',object$name,
+                           '" is not valid because ',
+                           eval(k$msg,env=list2env(slots(object)))
+                    )
+                )
             }
         }
-        # if no messages the all checks passed
         if (length(msg)==0) {
             return(TRUE)
-        } else {  # otherwise return message
+        } else {
             return(msg)
         }
     }
@@ -112,62 +111,130 @@ check_init_val=function(value,type) {
 #' @rdname entity
 #' @export
 setMethod(f = "value",
-    signature = c("entity"),
-    definition = function(obj) {
-        return(obj@value)
-    }
+          signature = c("entity"),
+          definition = function(obj) {
+              return(obj@value)
+          }
 )
 
 #' @rdname entity
 #' @export
 setMethod(f = "value<-",
-    signature = c("entity"),
-    definition = function(obj,value) {
-        obj@value = value
-        validObject(obj)
-        return(obj)
-    }
+          signature = c("entity"),
+          definition = function(obj,value) {
+              obj@value = value
+              validObject(obj)
+              return(obj)
+          }
 )
 
 #' @rdname entity
 #' @export
 setMethod(f = "max_length",
-    signature = c("entity"),
-    definition = function(obj) {
-        return(obj@max_length)
-    }
+          signature = c("entity"),
+          definition = function(obj) {
+              return(obj@max_length)
+          }
 )
 
 #' @rdname entity
 #' @export
 setMethod(f = "max_length<-",
-    signature = c("entity"),
-    definition = function(obj,value) {
-        obj@max_length = value
-        validObject(obj)
-        return(obj)
-    }
+          signature = c("entity"),
+          definition = function(obj,value) {
+              obj@max_length = value
+              validObject(obj)
+              return(obj)
+          }
 )
 
 
 setMethod(f = 'show',
-    signature = c('entity'),
-    definition = function(object) {
-        callNextMethod() # force the default output
-
-        V=value(object)
-        if (is(V,'DatasetExperiment') | is(V,'SummarizedExperiment') | is(V,'matrix')) {
-            V=paste0(nrow(V), ' rows x ', ncol(V), ' columns (',class(V),')')
-        } else if (is.atomic(V)) {
-            V=V
-        } else {
-            V=class(V)
-        }
+          signature = c('entity'),
+          definition = function(object) {
+              callNextMethod() # force the default output
 
-        # add extra info
-        cat('value:         ', V, '\n',sep='')
-        cat('type:          ', paste0(object$type,collapse=', '), '\n',sep='')
-        cat('max length:    ', max_length(object),sep='')
-        cat('\n')
-    }
+              V=value(object)
+              if (is(V,'DatasetExperiment') | is(V,'SummarizedExperiment') | is(V,'matrix')) {
+                  V=paste0(nrow(V), ' rows x ', ncol(V), ' columns (',class(V),')')
+              } else if (is.atomic(V)) {
+                  V=V
+              } else {
+                  V=class(V)
+              }
+
+              # add extra info
+              cat('value:         ', V, '\n',sep='')
+              cat('type:          ', paste0(object$type,collapse=', '), '\n',sep='')
+              cat('max length:    ', max_length(object),sep='')
+              cat('\n')
+          }
+)
+
+
+#' Entity constraints
+#'
+#' This helper function creates a list of quosures that can be used to apply
+#' constraints to an entity object.
+#'
+#' @export
+#' @param ... any number of constraints e.g. value<6
+#' @returns A list of quosures that will be evaluated to check validity of the entity
+#' @examples
+#' # ensure the value of an entity is exactly 6
+#' constraint(value==6)
+#'
+#' # check the length
+#' constraint(length(value)==1)
+#'
+#'
+entity_constraint=function(ex,msg){
+    return(
+        list(
+            ex = enexpr(ex),
+            msg = enexpr(msg)
+        )
+    )
+}
+
+
+
+# function to return all slots as a list
+slots=function(object){
+    n = slotNames(object)
+    S = lapply(n,function(x){
+        return(slot(object,x))
+    })
+    names(S)=n
+    return(S)
+}
+
+# function to expand inherits to vectors/lists
+elements_inherit = function(x, class_name) {
+    sapply(x, function(el) inherits(el, class_name))
+}
+
+# check that all elements of a vector inherit one of the classes in 'type' INCLUDES LISTS
+vector_type_equals = entity_constraint(
+    ex = all(elements_inherit(value,type)) | ('ANY' %in% type),
+    msg = paste0('all elements in "value" must be ', paste0('"',type,'"',collapse=' or '),'.'))
+
+# check that the value is of the correct type
+type_equals = entity_constraint(
+    ex = inherits(value,type) | ('ANY' %in% type),
+    msg = paste0('"value" must be ', paste0('"',type,'"',collapse=' or '),'.')
 )
+
+# check length does not exceed value
+maximum_length = entity_constraint(
+    ex = length(value) <= max_length,
+    msg = paste0('the length of "value" must be less than or equal to ', max_length)
+)
+
+# check minimum value
+minimum_value = function(x) {
+    entity_constraint(
+        ex = all(value >= !!x),
+        msg = paste0('"value" must be greater than ', !!x)
+    )
+}

R/entity_class.R

@@ -45,7 +45,7 @@ iris_DatasetExperiment = function () {
 #' @param value_0 a numeric value
 #' @param value_1 a numeric value
 #' @param value_2 a numeric value
-#' @param ... additional slots and values to pass to struct_class 
+#' @param ... additional slots and values to pass to struct_class
 #' @rdname example_model
 #' @include model_class.R
 #' @examples