fix broken tests

Author: grlloyd

R/entity_class.R

@@ -37,7 +37,7 @@ entity<-setClass(
         value='',
         type='character',
         max_length=1
-        ),
+    ),
     validity = function(object) {
         check_length=length(value(object)) <= max_length(object)
         check_type=class(value(object))[1] %in% type(object)
@@ -56,6 +56,38 @@ entity<-setClass(
     }
 )
 
+## initialise parameters on object creation
+setMethod(f="initialize",
+    signature="entity",
+    definition=function(.Object,...)
+    {
+        L=list(...)
+        SN=slotNames(.Object)
+        if (length(L)>0)
+        {
+            for (i in seq_len(length(L)))
+            {
+                if (names(L)[[i]] %in% SN) {
+                    slot(.Object,names(L)[[i]])=L[[names(L)[[i]]]]
+                }
+            }
+        }
+
+        if (!('value' %in% names(L))) {
+            if (isVirtualClass(.Object@type)) {
+                # create a spoof object until a real one is generated
+                x=numeric(0)
+                class(x)=.Object@type
+                .Object@value=x
+            } else {
+                .Object@value=new(.Object@type)
+            }
+        }
+        validObject(.Object)
+        return(.Object)
+    }
+)
+
 #' @describeIn entity get the value for an entity
 #' @export
 setMethod(f="value",

R/generics.R

@@ -21,7 +21,7 @@
 #' obj = param.obj(M, 'value_0')
 #'
 #' # set a parameter as an object
-#' param.obj(M, 'value_0') = entity(value = 15)
+#' param.obj(M, 'value_0') = entity(value = 15,type='numeric')
 #'
 setGeneric("param.obj",function(obj,name)standardGeneric("param.obj"))
 
@@ -152,7 +152,7 @@ setGeneric("output.value",function(obj,name)standardGeneric("output.value"))
 #' @return struct object
 #' @examples
 #' M = example_model()
-#' output.value(M,'result_1') = 0.95
+#' output.value(M,'result_1') = 'example'
 #'
 setGeneric("output.value<-",
     function(obj,name,value)standardGeneric("output.value<-"))
@@ -176,7 +176,7 @@ setGeneric("output.value<-",
 #' obj = output.obj(M, 'result_1')
 #'
 #' # set a output as an object
-#' output.obj(M, 'result_1') = entity(value = 15)
+#' output.obj(M, 'result_1') = entity(value = 15,type='numeric')
 #'
 setGeneric("output.obj",
     function(obj,name)standardGeneric("output.obj"))

R/method_class.R

@@ -26,6 +26,7 @@ method<-setClass(
 #' @export
 #' @examples
 #' D = iris_dataset() # example dataset
+#' M = method() # create a method object
 #' M = method.apply(M,D) # apply method to data
 #'
 setMethod(f="method.apply",
@@ -59,7 +60,8 @@ setMethod(f='predicted',
 #' \dontrun{
 #'
 #' M = method()
-#' predicted.name(M)
+#' predicted.name(M) = 'example' # set
+#' predicted.name(M)             # get
 #' }
 #'
 setMethod(f='predicted.name',

man/method-class.Rd

@@ -10,7 +10,9 @@ test_that('params and outputs',{
             outputs.result_1='entity',
             outputs.result_2='numeric'
         ),
-        prototype=list(predicted='result_1')
+        prototype=list(
+            predicted='result_1',
+            outputs.result_1=entity(name='result_1',type='numeric',value=0))
     )
 
     ## test return objects
@@ -21,7 +23,7 @@ test_that('params and outputs',{
     expect_identical(obj,numeric(0))
     # outputs
     obj = output.obj(test_model(),'result_1')
-    expect_identical(obj,entity())
+    expect_true(is(obj,'entity'))
     obj = output.obj(test_model(),'result_2')
     expect_identical(obj,numeric(0))
 
@@ -40,31 +42,32 @@ test_that('params and outputs',{
     expect_equal(param.name(TM,'value_1'),'pickle')
     expect_equal(param.name(TM,'value_2'),'value_2')
     # outputs
-    output.obj(TM,'result_1')=entity(name='carrot')
+    output.obj(TM,'result_1')=entity(name='carrot',type='numeric',value=10)
     expect_equal(output.name(TM,'result_1'),'carrot')
     expect_equal(output.name(TM,'result_2'),'result_2')
 
     ## test set lists
-    L=list('value_1'=10,value_2=20)
+    L=list('value_1'='banana',value_2=20)
     param.list(TM)=L
-    expect_equal(param.value(TM,'value_1'),10)
+    expect_equal(param.value(TM,'value_1'),'banana')
     expect_equal(param.value(TM,'value_2'),20)
     names(L)=c('result_1','result_2')
+    L$result_1=10
     output.list(TM)=L
     expect_equal(output.value(TM,'result_1'),10)
     expect_equal(output.value(TM,'result_2'),20)
 
     ## get lists
     K=param.list(TM)
-    expect_identical(K,list(value_1=10,value_2=20))
+    expect_identical(K,list(value_1='banana',value_2=20))
     # output
     J=output.list(TM)
     expect_identical(J,list(result_1=10,result_2=20))
 
     ## $ and $<-
     #params
-    TM$value_1=777
-    expect_equal(TM$value_1,777)
+    TM$value_1='cabbage'
+    expect_equal(TM$value_1,'cabbage')
     expect_error(TM$value_3)
     expect_error({TM$value_3=999})
 
@@ -74,7 +77,8 @@ test_that('params and outputs',{
         slots=c(
             outputs.result_1='entity',
             outputs.result_2='numeric'
-        )
+        ),
+        prototype = list(outputs.result_1=entity(type='numeric',value=1))
     )
     TM=test_model2()
     # outputs

man/output.obj.Rd

@@ -6,8 +6,8 @@ test_that('stato object',{
         slots=c(params.value_1='entity.stato',
              outputs.value_1='entity.stato'),
         prototype=list(stato.id='OBI:0200201',
-            params.value_1=entity.stato(value=1,stato.id='OBI:0000175'),
-            outputs.value_1=entity.stato(value=1,stato.id='OBI:0000175'))
+            params.value_1=entity.stato(value=1,stato.id='OBI:0000175',type='numeric'),
+            outputs.value_1=entity.stato(value=1,stato.id='OBI:0000175',type='numeric'))
         )
     S=test_class()
     expect_equal(stato.id(S),'OBI:0200201')