[Ruler-commits] r18 - pkg
noreply at r-forge.r-project.org
noreply at r-forge.r-project.org
Thu Jul 26 12:32:20 CEST 2012
Author: merysionek
Date: 2012-07-26 12:32:19 +0200 (Thu, 26 Jul 2012)
New Revision: 18
Modified:
pkg/New.R
Log:
.
Modified: pkg/New.R
===================================================================
--- pkg/New.R 2012-07-25 16:57:56 UTC (rev 17)
+++ pkg/New.R 2012-07-26 10:32:19 UTC (rev 18)
@@ -59,7 +59,17 @@
})
#[4] DIGITSUM
+digits <- function(x) {
+ if(length(x) > 1 ) {
+ lapply(x, digits)
+ } else {
+ n <- nchar(x)
+ rev( x %/% 10^seq(0, length.out=n) %% 10 )
+ }
+}
+
+
setClass("DigSumSingleRule", contains="SingleRule",S3methods=TRUE)
setMethod("calculateSpecific",signature(x="DigSumSingleRule",y="numeric"),
@@ -67,9 +77,27 @@
return(sum(digits(y)))
})
+#[5] NEGATIVE
+setClass("NegativeSingleRule", contains="SingleRule",S3methods=TRUE)
+setMethod("calculateSpecific",signature(x="NegatieSingleRule",y="numeric"),
+ function(x,y){
+ return(-y)
+ })
+
+#[4] IDENTICAL FUNCTION (input=output) used in random sequence generation
+setClass("IdenSingleRule",contains="SingleRule",S3methods=TRUE)
+
+setMethod("calculateSpecific",signature(x="IdenSingleRule",y="numeric"),
+ function(x,y){
+ return(y)
+ })
+
+
+
+
#EXECUTING RULES REFERING TO SINGLE ARGUMENT
@@ -92,9 +120,15 @@
#-------------------------------------------------------------------------------------------
#VIRTUAL CLASS FOR RULES OPERATING ON TWO ARGUMENTS
-setClass("DoubleRule", representation = representation(firstRule="SingleRule", secondRule="SingleRule"),
+# firstRule - operations to be executed at the first element of the numeric sequence (it is an object of class 'SingleRule')
+# secondRule - operations to be executed at the second element of the numeric sequence (it is an object of class 'SingleRule')
+# nextSingle - operation to be executed at the result of function DoubleRule
+
+
+setClass("DoubleRule", representation = representation(firstRule="SingleRule", secondRule="SingleRule",nextSingle="SingleRule"),
S3methods=TRUE)
+
calculateDoubleSpecific <- function(x,y,z){stop ("No method to calculate it.")} #throw a mistake
@@ -131,7 +165,6 @@
-
#EXECUTING RULES OPERATING ON TWO ARGUMENTS
calculateDouble <- function(x,y,z){stop ("No function to execute this.")} #throw a mistake, because you should execute just single functions contained by cladd DoubleRule
@@ -145,11 +178,18 @@
if(!is.null(x at firstRule)){ #if there are some rules nested inside
firstArg <- calculate(x at firstRule,firstArg) #execute first single-argument rule
}
+
if(!is.null(x at secondRule)){
secondArg <- calculate(x at secondRule,secondArg) #execute second single-argument rule
}
- return(calculateDoubleSpecific(x,firstArg, secondArg)) #if there are no more nested rules, execute
+ result<-calculateDoubleSpecific(x,firstArg, secondArg) #if there are no more nested rules, execute
+
+ if(!is.null(x at nextSingle)){
+ result<-calculate(x at nextSingle, result)
+ }
+ return(result)
+
})
#-------------------------------------------------------------------------------------------
@@ -157,52 +197,302 @@
#-------------------------------------------------------------------------------------------
p<-new("AddConstSingleRule", constantVal=6)
+calculate(p,4)# 4+6=10
+
+p<-new("AddConstSingleRule", constantVal=6)
q<-new("MultConstSingleRule", constantVal=10, previousRule=p)
-
-calculate(p,4)# 4+6=10
calculate(q,4)# (4+6)*10=100
-s<-new("MultDoubleRule", firstRule=p)
+#[A]
+n<-new("SubsDoubleRule")
+calculateDouble(n,10,12) #10-12=-2
+
+#[B]
+p<-new("DigSumSingleRule")
+g<-new("AddDoubleRule", firstRule=p)
+calculateDouble(g,12,34) # (1+2)+34=37 // take the digitsum of the first argument and add it to the second one
+
+#[C]
+p<-new("DigSumSingleRule")
+g<-new("AddDoubleRule", secondRule=p)
+calculateDouble(g,12,34)# 12+(3+4)=19 // take the digitsum of the second argument and add it to the first one
+
+#[D]
+p<-new("DigSumSingleRule")
+g<-new("AddDoubleRule", firstRule=p, secondRule=p)
+calculateDouble(g,12,34)# (1+2)+(3+4)=10 // take the digitsum of the second argument,take the digitsum of the first argument and add them up
+
+#[E]
+p<-new("DigSumSingleRule")
+g<-new("AddDoubleRule", firstRule=p, secondRule=p, nextSingle=p)
+calculateDouble(g,12,34) #(1+2)+(3+4)=10, digitSum(10)=1+0=1 // take the digitsum of the second argument,take the digitsum of the first argument. Add those values up. Take the digitSum of the result.
+
+
+#OTHER EXAMPLES
r<-new("AddDoubleRule")
+calculateDouble(r,3,2)# 3+2=5 // add two arguments
-calculateDouble(s,2,2)# (2+6)*2=16
-calculateDouble(r,3,2)# 3+2=5
-
k<-new("SubsConstSingleRule",constantVal=1)
calculate(k,12) #12-1=11
+k<-new("SubsConstSingleRule",constantVal=1)
m<-new("SubsDoubleRule", firstRule=k)
-calculateDouble(m,10,12) #(10-1)-12=-3
+calculateDouble(m,10,12) #(10-1)-12=-3 //substract 1 from the first argument and substract the second argument from the result
-n<-new("SubsDoubleRule")
-calculateDouble(n,10,12) #10-12=-2
+s<-new("MultDoubleRule", firstRule=p)
+calculateDouble(s,2,2)# (2+6)*2=16 // multiply two arguments
+p<-new("DigSumSingleRule")
+s<-new("AddDoubleRule", nextSingle=p)
+calculateDouble(s,11,14) #11+14=25 and 2+5=7 // sume two arguments and take the digitsum of the result
-jjj<-new("AddDigSumDoubleRule")
-calculateDouble(jjj,12,13) # (1+2)+13=16
+p<-new("AddConstSingleRule", constantVal=6)
+s<-new("AddDoubleRule", nextSingle=p)
+calculateDouble(s,11,14) #(11+14)+6=31 // add two arguments and add 6
-p<-new("DigSumSingleRule")
-g<-new("AddDoubleRule", firstRule=p)
-calculateDouble(g,12,34) #adding a digitsum to the second word
-
-
#-------------------------------------------------------------------------------------------
#----------------------------------generating sequences-------------------------------------
#-------------------------------------------------------------------------------------------
-#n - how long should be a sequence
-#rule
+#a list of single rules
+singleRules<-list(list(ruleName="AddConstSingleRule",argumentName=c("previousRule","constantVal"), argumentType= c("SingleRule","numeric")),
+list(ruleName="MultConstSingleRule",argumentName=c("previousRule","constantVal"), argumentType= c("SingleRule","numeric")),
+list(ruleName="SubsConstSingleRule",argumentName=c("previousRule","constantVal"), argumentType= c("SingleRule","numeric")),
+list(ruleName="DigSumSingleRule",argumentName=c("previousRule"), argumentType= c("SingleRule")),
+list(ruleName="NegativeSingleRule",argumentName=c("previousRule"), argumentType= c("SingleRule")))
-sequence<-function(rule,n,a){
- if(class(rule)=="SingleRule"){
+
+#a list of double rules
+doubleRules<-list(list(ruleName="AddDoubleRule",argumentName=c("firstRule","secondRule","nextSingle"), argumentType= c("SingleRule","SingleRule","SingleRule")),
+list(ruleName="MultDoubleRule",argumentName=c("firstRule","secondRule","nextSingle"), argumentType= c("SingleRule","SingleRule","SingleRule")),
+list(ruleName="SubsDoubleRule",argumentName=c("firstRule","secondRule","nextSingle"), argumentType= c("SingleRule","SingleRule","SingleRule")))
+
+
+
+
+# A FUNCTION TO CREATE A SINGLE RULE
+
+# 'a' is an index of a rule on singleRules list (which rule I want to use to create a sequence) - if not specyfied it will be generated
+# 'cv' constant value (default is NULL)
+# 'comb' is telling me whether I want to combine several rules
+
+#creating a simple singleRule object (with previous rules=NULL)
+createSR<-function(a=NULL,cv=NULL){
+ if(!is.null(a) && a>length(singleRules)) stop (paste("The list of SingleRules is shoreter than ",a, ".Please specify 'a' value, which is smaller than or equal to",length(singleRules)))
+
- }
-
- if(class(rule)=="DoubleleRule"){
- }
-
- }
+ if(is.null(a)) a<-sample(1:length(singleRules),1) #if 'a' is not specyfied, generate it
+
+ a<-round(a)# 'a' needs to be integer
+
+ if(length(singleRules[[a]]$argumentName)>1){
+ if(is.null(cv)) cv<-sample(1:100,1)#if constant value is not sdpecyfied and an object needs it - generate it
+ p<-new(singleRules[[a]]$ruleName,constantVal=cv)} else{
+ p<-new(singleRules[[a]]$ruleName) #an object doesn't need a constant value
+ }
+ return(p)
+
+ }
+
+
+
+
+
+
+
+
+
+
+
+# A FUNCTION TO COMBINE TWO SINGLE RULES
+
+# 'obj1' is an object of class that inherits from SingleRule
+# 'obj2' is an object of class that inherits from SingleRule. It will be set as previousRule of object 1.
+
+combineSR<-function(obj1=NULL,obj2=NULL){
+ if(!is.null(obj1) && !inherits(obj1,"SingleRule")) stop (paste("argument obj1", obj1, "should be of class 'SingleRule'or inherit from it. It cannot be of class '", class(obj), "'", sep=""))
+ if(!is.null(obj1) && !inherits(obj2,"SingleRule")) stop (paste("argument obj2", obj2, "should be of class 'SingleRule'or inherit from it. It cannot be of class '", class(obj), "'", sep=""))
+
+ if(is.null(obj2)) obj2<-createSR() #create a SingleRule object 'obj2' if it was not delivered as an argument
+ if(is.null(obj1)) obj1<-createSR() #create a SingleRule object 'obj1'if it was not delivered as an argument
+
+ obj1 at previousRule<-obj2
+
+ return(obj1)
+ }
+
+
+
+
+
+
+
+
+
+# # A FUNCTION TO CREATE A DOUBLE RULE (a single one)
+#
+# #'a' is an index of the rule on doubleRules list
+# createDR<-function(a=NULL){
+# if(!is.null(a) && a>length(doubleRules)) stop (paste("The list of doublrRules is shoreter than ",a, ".Please specify 'a' value, which is smaller than or equal to",length(doubleRules)))
+# if(is.null(a)) {a<-sample (1:length(doubleRules),1)}
+# a<-round(a) # 'a' needs to be an integer
+#
+# p<-new(doubleRules[[a]]$ruleName)
+# return(p)
+# }
+
+
+
+
+
+
+
+
+
+
+
+# A FUNCTION TO COMBINE DOUBLE RULES - it generates all parameters automatically
+
+#'fr' firstRule argument of an object of class doubleRule
+#'sr' secondRule argument of an object of class doubleRule
+#'ns' nextSingle argument of an object of class doubleRule
+combineDR<-function(a=NULL,fr=NULL,sr=NULL,ns=NULL){
+ if(!is.null(a) && a>length(doubleRules)) stop (paste("The list of doublrRules is shoreter than ",a, ".Please specify 'a' value, which is smaller than or equal to",length(doubleRules)))
+ if(!inherits(fr,"singleRule") && !is.null(fr))stop(paste("'fr' argument must inherit from class singleRule"))
+ if(!inherits(sr,"singleRule") && !is.null(sr))stop(paste("'sr' argument must inherit from class singleRule"))
+ if(!inherits(ns,"singleRule") && !is.null(ns))stop(paste("'ns' argument must inherit from class singleRule"))
+
+
+
+
+
+
+ if(is.null(a)) a<-sample(1:length(doubleRules),1) #generate an index of a doubleRule from the list of doubleRules
+ a<-doubleRules[[a]]$ruleName
+ #print(a)
+
+ if(is.null(fr)) fr<-sample(c(k=createSR(),k=new("IdenSingleRule")),1,prob=c(0.5,0.5))# firstRule is chosen from an automatically generated SingleRule or identical rule returning the input
+
+ if(is.null(sr)) sr<-sample(c(k=createSR(),k=new("IdenSingleRule")),1,prob=c(0.3,0.7)) #because adding more and more rules makes the rule very difficult I would generate identical function with greater probability
+
+ if(is.null(ns)) ns<-sample(c(k=createSR(),k=new("IdenSingleRule")),1,prob=c(0.3,0.7))
+
+ p<-new(a,firstRule=fr$k, secondRule=sr$k,nextSingle=ns$k)
+ return(p)
+
+ }
+
+
+
+
+#A FUNCTION TO GENERATE NUMERIC SEQUENCE OF DECLARED LENGTH
+# 'n' is the length of the numeric sequence (default value is 6)
+# 'x1', 'x2' are the first elements of the numeric sequence (you don't always need 'x2')
+sequence<-function(x1,x2=NULL,rule,n=6){
+ if(inherits(rule,"DoubleRule") && is.null(x2)) stop (" If you want to use a DoubleRoule you need to specify x2")
+ if(class(x1)!="numeric" ||(class(x2)!="NULL" && class(x2)!="numeric")) stop ("arguments 'x1', 'x2' must be of type 'numeric'.")
+ if(!inherits(rule,"SingleRule") && !inherits(rule,"DoubleRule")) stop ("'rule' argument must inherit from 'SingleRule' or 'DoubleRule' class")
+ if(n<3) stop("sequence must be longer than 3")
+
+ k<-list()
+ k[1]=x1
+
+
+
+ if(inherits(rule,"SingleRule")){
+ for(i in 2:n){
+ k[i]<-calculate(x=rule,y=k[[i-1]])
+ }
+
+ }else{
+ k[2]=x2
+ for(i in 3:n){
+ k[i]<-calculateDouble(x=rule,y=k[[i-2]],z=k[[i-1]])
+ }
+
+ }
+ return(k)
+
+ }
+
+
+
+# checking if a vector is in any row of the matrix
+#'mx' is a matrix in which I am searching
+#'vec' is a vector which is being checked
+
+duplicate<-function(mx,vec){
+ return(any(apply(mx, 1, function(x, want) isTRUE(all.equal(x, want)), vec)))
+ }
+
+
+
+
+
+#CHECKING IF THE SEQUENCE IS NOT CONSTANT
+# it returns '0' when teh sequence is constant and '1' when the sequence is not constant
+
+conCheck<-function(seq){
+ if(class(seq)!="list") stop("sequence must be of type 'list'")
+
+ m<-length(seq)
+
+ if(identical(seq[m],seq[m-1]) && identical(seq[m],seq[m-2]) ) {return(0)} else {return(1)}
+ }
+
+
+
+
+
+
+# checking whether the sequence is not constant, numbers are not greater than 1000 or no lesser than -1000
+check<-function(seqlen){
+ x1<-as.numeric(sample(1:100,1)) #generate the first element of numeric sequence
+ x2<-as.numeric(sample(1:100,1)) # generate the second element of numeric sequence
+ m<-sample(c(1,2,3),1) #if m=1 I will create a singleRule, if m=2 rule will be a combination of singleRules, if m=3 rule is a doubleRule
+ #print(paste("items inside check",items))
+
+ if(m==1){rule<-createSR()} else{
+ if(m==2){rule<-combineSR(createSR(),createSR())} else {rule<-combineDR()}}
+
+
+ result<-sequence(x1,x2,rule,n=seqlen)
+
+ if(conCheck(result)==0 || result[length(result)]>1000 || result[length(result)]< -1000){check(seqlen)} else{return(result)}
+
+ }
+
+
+
+
+
+
+
+
+
+
+# AUTOMATIC TEST GENERATION
+# random
+# 'seqlen' specyfies how long should a single sequence be
+# 'testlen' specyfies how many sequences (item positions) are there to be in a test
+automaticTest<-function(testlen,seqlen=6){
+ items<-matrix(NA,testlen,seqlen) #I will store generated items in a matrix
+ rules<- list() # I will keep the rules on a list
+
+ for(i in 1:testlen){
+ #print(paste("items inside automativTest", items))
+ items[i,]<- unlist(check(seqlen))
+
+ }
+
+ return(items)
+ }
+
+
+
+
+
More information about the Ruler-commits
mailing list