[Ruler-commits] r51 - / pkg/ruleR pkg/ruleR/R pkg/ruleR/man
noreply at r-forge.r-project.org
noreply at r-forge.r-project.org
Thu Sep 20 16:15:18 CEST 2012
Author: merysionek
Date: 2012-09-20 16:15:18 +0200 (Thu, 20 Sep 2012)
New Revision: 51
Added:
pkg/ruleR/DESCRIPTION
pkg/ruleR/NAMESPACE
pkg/ruleR/R/ruleR_upgraded_final.R
pkg/ruleR/man/DictionaryRule-class.Rd
pkg/ruleR/man/Rule-class.Rd
pkg/ruleR/man/b.Rd
pkg/ruleR/man/basicDictionary.Rd
pkg/ruleR/man/createDictRule.Rd
pkg/ruleR/man/createTest.Rd
pkg/ruleR/man/extract_double_comment.Rd
pkg/ruleR/man/extract_single_comment.Rd
pkg/ruleR/man/generateRule.Rd
pkg/ruleR/man/generate_cv.Rd
pkg/ruleR/man/nest.Rd
pkg/ruleR/man/print.Rule.Rd
pkg/ruleR/man/sequenceR.Rd
pkg/ruleR/man/split_dict.Rd
pkg/ruleR/man/val.Rd
pkg/ruleR/man/vecORnull-class.Rd
pkg/ruleR/man/writing_double.Rd
pkg/ruleR/man/writing_single.Rd
pkg/ruleR/man/ws.Rd
Removed:
pkg/ruleR/R/ruleR.R
pkg/ruleR/man/AddRule.Rd
pkg/ruleR/man/DivDoubleRule-class.Rd
pkg/ruleR/man/ExpDoubleRule-class.Rd
pkg/ruleR/man/ModuloDoubleRule-class.Rd
pkg/ruleR/man/MyRules.Rd
pkg/ruleR/man/NegativeSingleRule-class.Rd
pkg/ruleR/man/SubsConstSingleRule-class.Rd
pkg/ruleR/man/SubsDoubleRule-class.Rd
pkg/ruleR/man/VerifTable.Rd
pkg/ruleR/man/automaticTest.Rd
pkg/ruleR/man/sequence.Rd
plot.default.Rd
Modified:
pkg/ruleR/man/AddConstSingleRule-class.Rd
pkg/ruleR/man/AddDoubleRule-class.Rd
pkg/ruleR/man/DigSumSingleRule-class.Rd
pkg/ruleR/man/DoubleRule-class.Rd
pkg/ruleR/man/IdenSingleRule-class.Rd
pkg/ruleR/man/MultConstSingleRule-class.Rd
pkg/ruleR/man/MultDoubleRule-class.Rd
pkg/ruleR/man/SingleRule-class.Rd
pkg/ruleR/man/calculate-methods.Rd
pkg/ruleR/man/calculate.Rd
pkg/ruleR/man/check.Rd
pkg/ruleR/man/conCheck.Rd
pkg/ruleR/man/createDR.Rd
pkg/ruleR/man/createSR.Rd
pkg/ruleR/man/duplicate.Rd
pkg/ruleR/man/print.DoubleRule.Rd
pkg/ruleR/man/print.SingleRule.Rd
pkg/ruleR/man/ruleR-package.Rd
pkg/ruleR/man/singleRules.Rd
Log:
new upgraded ruleR - enabling to set all parameters while creating a test. Deleted old ruleR files
Added: pkg/ruleR/DESCRIPTION
===================================================================
--- pkg/ruleR/DESCRIPTION (rev 0)
+++ pkg/ruleR/DESCRIPTION 2012-09-20 14:15:18 UTC (rev 51)
@@ -0,0 +1,11 @@
+Package: ruleR
+Type: Package
+Title: generating numeric sequence items for intelligence tests
+Version: 1.0
+Date: 2012-07-31
+Author: Maria Rafalak(Polish Psychological Tests Laboratory), Philipp Doebler (University of Muenster)
+Maintainer: Maria Rafalak <m.rafalak at practest.com.pl>
+Description: This package helps to generate items for intelligence tests. Items are number sequences and are generated according to the implemented basic rules. Those rules can be easily combined either by a user or automatically. The package generates also 'noise answers' (distractors) helpful in creating items with specified response options.
+Depends: methods
+License: GPL-2
+
Added: pkg/ruleR/NAMESPACE
===================================================================
--- pkg/ruleR/NAMESPACE (rev 0)
+++ pkg/ruleR/NAMESPACE 2012-09-20 14:15:18 UTC (rev 51)
@@ -0,0 +1,18 @@
+exportPattern("^[[:alpha:]]+")
+exportMethods(
+ "calculate",
+ "calculateSpecific"
+)
+exportClasses(
+ "AddConstSingleRule",
+ "AddDoubleRule",
+ "DictionaryRule",
+ "DigSumSingleRule",
+ "DoubleRule",
+ "IdenSingleRule",
+ "MultConstSingleRule",
+ "MultDoubleRule",
+ "Rule",
+ "SingleRule",
+ "vecORnull"
+)
Deleted: pkg/ruleR/R/ruleR.R
===================================================================
--- pkg/ruleR/R/ruleR.R 2012-09-05 19:08:49 UTC (rev 50)
+++ pkg/ruleR/R/ruleR.R 2012-09-20 14:15:18 UTC (rev 51)
@@ -1,500 +0,0 @@
-#-------------------------------------------------------------------------------------------
-#------------------------------SingleRules--------------------------------------------------
-#-------------------------------------------------------------------------------------------
-
-#VIRTUAL CLASS FOR RULES OPERATING ON SINGLE ARGUMENTS
-
-setClass("SingleRule",
- representation = representation(previousRule="SingleRule"),
- S3methods=TRUE)
-
-
-calculateSpecific <- function(x,y,z=NULL){
- return(y)
-}
-
-
-setMethod("calculateSpecific",signature(x="SingleRule", y="numeric"),
- function(x,y){
- return(y)
- })
-
-
-
-
-#[0] 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)
- })
-
-
-#[1] RULE 1 - ADDING A CONSTANT
-
-setClass("AddConstSingleRule",
- contains="SingleRule",
- representation(constantVal="numeric"),
- S3methods=TRUE)
-
-setMethod("calculateSpecific",signature(x="AddConstSingleRule", y="numeric"),
- function(x,y){
- return(x at constantVal+y)
- })
-
-
-#[2] RULE 2 - MULTIPLYING BY A CONSTANT
-
-setClass("MultConstSingleRule",
- contains="SingleRule",
- representation(constantVal="numeric"),
- S3methods=TRUE)
-
-setMethod("calculateSpecific",signature(x="MultConstSingleRule", y="numeric"),
- function(x,y){
- return(x at constantVal*y)
- })
-
-
-
-#[4] DIGITSUM
-digits <- function(x) {
- x<-abs(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"),
- function(x,y){
- return(sum(digits(y)))
- })
-
-#[5] NEGATIVE
-
-setClass("NegativeSingleRule", contains="SingleRule",S3methods=TRUE)
-
-setMethod("calculateSpecific",signature(x="NegativeSingleRule",y="numeric"),
- function(x,y){
- return(-y)
- })
-
-
-
-
-
-
-#EXECUTING RULES REFERING TO SINGLE ARGUMENT
-
-
-calculate <- function(x,y,z=NULL){
- return(y)
-}
-
-
-setMethod("calculate",signature(x="SingleRule", y="numeric"), #both [1] and [2] inherit from class 'SingleRule'
- function(x, y){
- result<-y
- if(!is.null(x at previousRule)){ # if there are some rules nested inside 'x'
- result <- calculate(x at previousRule,result)
- }
- return(calculateSpecific(x,result)) # if there are no more nested functions, execute
- })
-
-#-------------------------------------------------------------------------------------------
-#------------------------------------------------DoubleRules--------------------------------
-#-------------------------------------------------------------------------------------------
-#VIRTUAL CLASS FOR RULES OPERATING ON TWO ARGUMENTS
-
-# 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)
-
-
-
-#[1] ADD TWO PREVIOUS EXPRESSIONS
-
-setClass("AddDoubleRule", contains="DoubleRule",S3methods=TRUE)
-
-setMethod("calculateSpecific",signature(x="AddDoubleRule", y="numeric", z="numeric"),
- function(x,y,z){
- return(y+z)
- })
-
-#[2] MULTIPLY TWO PREVIOUS EXPRESSIONS
-
-setClass("MultDoubleRule",contains="DoubleRule",S3methods=TRUE)
-
-
-setMethod("calculateSpecific",signature(x="MultDoubleRule", y="numeric", z="numeric"),
- function(x,y,z){
- return(y*z)
- })
-
-# #[3] SUBSTRACT TWO PREVIOUS EXPRESSIONS
-#
-# setClass("SubsDoubleRule",contains="DoubleRule",S3methods=TRUE)
-#
-#
-# setMethod("calculateSpecific",signature(x="SubsDoubleRule", y="numeric", z="numeric"),
-# function(x,y,z){
-# return(y-z)
-# })
-
-#[4] DIVIDING TWO NUMBERS (Philipp)
-
-setClass("DivDoubleRule",contains="DoubleRule",S3methods=TRUE)
-
-setMethod("calculateSpecific",
- signature(x="DivDoubleRule", y="numeric", z="numeric"),
- function(x,y,z){
- return(y%/%z)
- })
-
-#[5] MODULO (Philipp)
-
-setClass("ModuloDoubleRule",contains="DoubleRule",S3methods=TRUE)
-
-setMethod("calculateSpecific",
- signature(x="ModuloDoubleRule", y="numeric", z="numeric"),
- function(x,y,z){
- return(y%%z)
- })
-
-#[6] EXPONENTIAL FUNCTION (Philipp)
-setClass("ExpDoubleRule", contains="DoubleRule",S3methods=TRUE)
-
-setMethod("calculateSpecific",
- signature(x="ExpDoubleRule", y="numeric", z="numeric"),
- function(x,y,z){
- return(y^z)
- })
-
-
-
-#EXECUTING RULES OPERATING ON TWO ARGUMENTS
-
-
-setMethod("calculate",signature(x="DoubleRule", y="numeric", z="numeric"),
- function(x, y, z){
- firstArg <- y #first element of the sequence
- secondArg <-z #second element of the sequence
-
- 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
- }
-
- result<-calculateSpecific(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)
-
- })
-
-
-
-#-------------------------------------------------------------------------------------------
-#----------------------------------generating sequences-------------------------------------
-#-------------------------------------------------------------------------------------------
-
-#a list of single rules
-singleRules<-list("IdenSingleRule","AddConstSingleRule","MultConstSingleRule","DigSumSingleRule","NegativeSingleRule")
-
-
-#a list of double rules
-doubleRules<-list("AddDoubleRule","MultDoubleRule","DivDoubleRule","ModuloDoubleRule","ExpDoubleRule")
-
-
-
-#A FUNCTION TO CREATE SINGLE RULES
-# 'a1' is an index from table SingleRule (default a=NULL) //if 'a' is NULL it will be generated
-# 'n' how many rules are to be nested (default=NULL menas that I want to generate it automatically let's say from c(0,1,2)
-# n=0 would mean that I want to create just one rule with nothing nested inside)
-# 'cv1' is a constant value
-# '...' if I would like to add some rules nested I can provide their parameters cv must be always supplied #9even if the function doesn't require that
-
-createSR<-function(a1=NULL,cv1=NULL,n=NULL,...){
- p<-list(...)#arguments for nesting other functions
- p<-unlist(p)
-
- #if(!is.null(n) && length(p)!=2*n) stop (paste("parameters of functions to be nested do not match n=",n))
- #for(i in seq(1,length(p),by=2)){if(k[i]>length(p)) stop (paste("List of rules is shorter than ",k[i]))}
-
- if(is.null(a1)) {a1<-sample(2:length(singleRules),1)} #generate 'a' if no is supplied (we don't want to generate a=1 because it is identical function)
- if(is.null(cv1)) {cv1<-sample(-100:100,1)} # generate a constant value if no is supplied
- if(is.null(n)){n<-sample(c(0,1,2),1,prob=c(3/6,2/6,1/6)) #nesting more than two rules would be impossible to guess
- k<-1:length(singleRules) #preventing nesting the same rules of the same class together
- r<-sample(k[-a1],n,replace=FALSE)#generating rules to be nested
- co<-sample(1:100,n) # generating constant values for nested rules
- p<-as.vector(rbind(r,co))
-
- } # generate 'n' if it is set as null with different probabilities
-
-
- if("constantVal"%in%slotNames(singleRules[[a1]])){m<-new(singleRules[[a1]],constantVal=cv1,previousRule=new("IdenSingleRule"))
- }else{m<-new(singleRules[[a1]],previousRule=new("IdenSingleRule"))}
-
- if(n!=0) {k<-createSR(p[[1]],p[[2]],n-1,p[-c(1,2)])
- m at previousRule<-k}#else{m at previousRule<-new("IdenSingleRule")}
-
- return(m)
-}
-
-
-# A FUNCTION TO COMBINE DOUBLE RULES - it generates all parameters automatically
-
-
-#preventing from more than one adding constant rule to be applied
-# 'dr' - double rule (string)
-redundancy_ch<-function(fr,sr,ns,a){
- if(a==1) dr="AddConstSingleRule"
- if(a==2) dr="MultConstSingleRule"
-
- b<-list(fr,sr,ns)
- vec<-vector(mode="list",length=length(b))
- for(i in 1:length(b))vec[i]<-inherits(b[[i]],dr) #list of logical values
-
- redundancy<-which(vec==TRUE) #showing which elements inherit from class "AddConstSingleRule"
- length_red<-length(redundancy)
- if(length_red>=2){b[[redundancy[length_red]]]<-sample(c(createSR(),new("IdenSingleRule")),1,prob=c(0.3,0.7))[[1]]
- fr<-b[[1]];sr<-b[[2]];ns<-b[[3]];a=a
- redundancy_ch(fr,sr,ns,a)
- }else{return(b)}
-
-
- }
-
-
-
-# 'a' is index from a list of DoubleRules
-#'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
-#'
-createDR<-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(fr)) fr<-sample(c(createSR(),new("IdenSingleRule")),1,prob=c(0.5,0.5))[[1]]# firstRule is chosen from an automatically generated SingleRule or identical rule returning the input
-
- if(is.null(sr)) {sr<-sample(c(createSR(),new("IdenSingleRule")),1,prob=c(0.3,0.7))[[1]] #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(createSR(),new("IdenSingleRule")),1,prob=c(0.3,0.7))[[1]]
-
- if(is.null(a)) a<-sample(1:length(doubleRules),1) #generate an index of a doubleRule from the list of doubleRules
-
- if(a%in%c(1,2)){k<-redundancy_ch(fr=fr,sr=sr,ns=ns,a=a);fr<-k[[1]];sr<-k[[2]];ns<-k[[3]]}#preventing redundancy
-
-
- a<-doubleRules[[a]]
-
-
- p<-new(a,firstRule=fr, secondRule=sr,nextSingle=ns)
-
- 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]<-calculate(x=rule,y=k[[i-2]],z=k[[i-1]])
- }
-
- }
- return(list(k,rule))
-
- }
-
-
-
-
-
-# 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
-# result TRUE means that there is already such vector in the matrix
-
-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
-# a function examines three last elements of a sequence, so even sequences like 27,9,9,9,9 ... are excluded
-
-conCheck<-function(seq){
-
- if(class(seq)!="list") stop("sequence must be of type 'list'")
-
- m<-length(seq)
-
- b<-ifelse(identical(seq[m],seq[m-1]),0,
- ifelse(identical(c(seq[m],seq[m-1]),c(seq[m-2],seq[m-3])),0,
- ifelse(identical(c(seq[m],seq[m-1],seq[m-2]),c(seq[m-3],seq[m-4],seq[m-5])),0,1)))
-
-
- return(b)
- }
-
-
-
-# checking whether the sequence is not constant, numbers are not greater than 1000 or no lesser than -1000
-# type=1 is totally automatic / type=2 generates rules from 'MyRules' list
-check<-function(seqlen,items,type){
- 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
-
- if(type==1){ # type=1 means automatic tests
-
- m<-sample(c(1,2),1)
- if(m==1){rule<-createSR()} else{rule<-createDR()} # if m=1 create singleRule else create doubleRulre
-
- } else{z<-sample(2:length(MyRules),1); rule<-MyRules[[z]] }
-
- result<-sequence(x1,x2,rule,n=seqlen)[[1]]
-
- fun<-sequence(x1,x2,rule,n=seqlen)[[2]]
-
-
- if(conCheck(result)==0 ||any(is.na(result))|| max(unlist(result))>1000 || min(unlist(result))< -1000||duplicate(mx=items,vec=unlist(result[[1]])))
- {check(seqlen,items,type)} else{return(list(result=result,fun=fun))}
-
- }
-
-
-
-
-
-
-# AUTOMATIC TEST GENERATION
-# random
-# 'seqlen' specyfies how long should a single sequence be
-# 'type' = 1 everything generated automatically/ type=2 functions generated from the MyRules matrix
-# 'testlen' specyfies how many sequences (item positions) are there to be in a test
-automaticTest<-function(testlen,type=1,seqlen=6){
- if(class(type)!="numeric") stop ("argument 'type' must be of class 'numeric'")
- items<-matrix(NA,testlen,seqlen) #I will store generated items in a matrix
- rules<- list() # I will keep the rules on a list
- noise<-matrix(NA,testlen,5) # 5 noise answers will be stored in this matrix
-
- for(i in 1:testlen){
- b<-check(seqlen,items,type)
- items[i,]<-unlist(b[[1]]) # I treat last element as a correct answer
- rules[i]<-b[2]
- noise[i,] <-sample(c((items[i,seqlen]-6):(items[i,seqlen]+6))[-(seqlen+1)],5) # generate a sample of 5 elements from a set (correct answer-6: correct answer +6) excluding the correct answer
- }
-
- return(list(items=items,noise=noise,rules=rules))
-
- }
-
-
-
-
-#--------------------------------------------------------------------------------------------------------------------------------
-#---------------------------------------- rules defined by a user----------------------------------------------------------------
-#--------------------------------------------------------------------------------------------------------------------------------
-
-#LIST OF USER'S RULES
-
-
-# Verification table - in which I will store results of the rules
-# starting values are always 10 and 20, constantVal=14, seqlen=6
-# I check whether sequence generated for those values are identical for a new rule - if so - I won't add a new rule to the list
-
-VerifTable<-matrix(NA,1,6)
-
-MyRules<-list(NA)
-
-AddRule<-function(rule){
- if(!inherits(rule,"SingleRule") && !inherits(rule,"DoubleRule")) stop (paste("new Rule must be an object of class 'SingleRule' od 'DoubleRule'. It cannot be of class",class(rule)))
-
- s<-sequence(x1=10,x2=20,rule,n=6)
-
- if(duplicate(VerifTable,unlist(s[[1]]))==TRUE){stop ("There already is a rule that gives the same result.")} else{
- VerifTable<<-rbind(unlist(s[[1]]),VerifTable)
- MyRules[length(MyRules)+1]<<-rule
- print("Your rule succesfully added tp 'MyRule' list")
- }
- }
-
-
-#---------------------------------------------------------------------------
-#------function to print objects of class SingleRule and DoubleRule---------
-#---------------------------------------------------------------------------
-
-print.SingleRule<-function(x){
- pr<-function(x){
- cat(paste("\nname:", class(x)[1]))
- if("constantVal"%in%slotNames(x)) {cat(paste(", constant value: ", x at constantVal))}
- }
- pr(x)
-
- if(!class(x at previousRule)=="SingleRule"){x<-x at previousRule; print(x)}
-
- }
-
-
-
-print.DoubleRule<-function(x){
- x1=x
-
-
- cat(class(x1)[1])
-
- if("firstRule"%in%slotNames(x)){cat("\n FIRST RULE:"); x<-x at firstRule;print.SingleRule(x)}
- x=x1
- if("secondRule"%in%slotNames(x)){cat("\n SECOND RULE:"); x<-x at secondRule;print.SingleRule(x)}
- x=x1
- if("nextSingle"%in%slotNames(x)){cat("\n NEXT SINGLE:"); x<-x at nextSingle;print.SingleRule(x)}
-
- }
-
-
-
Added: pkg/ruleR/R/ruleR_upgraded_final.R
===================================================================
--- pkg/ruleR/R/ruleR_upgraded_final.R (rev 0)
+++ pkg/ruleR/R/ruleR_upgraded_final.R 2012-09-20 14:15:18 UTC (rev 51)
@@ -0,0 +1,871 @@
+#-------------------------------------------------------------------------------------------
+#------------------------------SingleRules--------------------------------------------------
+#-------------------------------------------------------------------------------------------
+
+#VIRTUAL CLASS FOR RULES OPERATING ON SINGLE ARGUMENTS
+
+setClass("SingleRule",
+ representation = representation(previousRule="SingleRule"),
+ S3methods=TRUE)
+
+
+calculateSpecific <- function(x,y,z=NULL){
+ return(y)
+}
+
+
+setMethod("calculateSpecific",signature(x="SingleRule", y="numeric"),
+ function(x,y){
+ return(y)
+ })
+
+
+
+
+#[0] 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)
+ })
+
+
+#[1] RULE 1 - ADDING A CONSTANT
+
+setClass("AddConstSingleRule",
+ contains="SingleRule",
+ representation(constantVal="numeric"),
+ S3methods=TRUE)
+
+setMethod("calculateSpecific",signature(x="AddConstSingleRule", y="numeric"),
+ function(x,y){
+ return(x at constantVal+y)
+ })
+
+
+#[2] RULE 2 - MULTIPLYING BY A CONSTANT
+
+setClass("MultConstSingleRule",
+ contains="SingleRule",
+ representation(constantVal="numeric"),
+ S3methods=TRUE)
+
+setMethod("calculateSpecific",signature(x="MultConstSingleRule", y="numeric"),
+ function(x,y){
+ return(x at constantVal*y)
+ })
+
+
+
+#[4] DIGITSUM
+digits <- function(x) {
+ x<-abs(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"),
+ function(x,y){
+ return(sum(digits(y)))
+ })
+
+#[5] NEGATIVE
+#
+# setClass("NegativeSingleRule", contains="SingleRule",S3methods=TRUE)
+#
+# setMethod("calculateSpecific",signature(x="NegativeSingleRule",y="numeric"),
+# function(x,y){
+# return(-y)
+# })
+
+
+
+
+
+
+#EXECUTING RULES REFERING TO SINGLE ARGUMENT
+
+
+calculate <- function(x,y,z=NULL){
+ return(y)
+}
+
+
+setMethod("calculate",signature(x="SingleRule", y="numeric"), #both [1] and [2] inherit from class 'SingleRule'
+ function(x, y){
+ result<-y
+ if(!is.null(x at previousRule)){ # if there are some rules nested inside 'x'
+ result <- calculate(x at previousRule,result)
+ }
+ return(calculateSpecific(x,result)) # if there are no more nested functions, execute
+ })
+
+#-------------------------------------------------------------------------------------------
+#------------------------------------------------DoubleRules--------------------------------
+#-------------------------------------------------------------------------------------------
+#VIRTUAL CLASS FOR RULES OPERATING ON TWO ARGUMENTS
+
+# 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)
+
+
+
+#[1] ADD TWO PREVIOUS EXPRESSIONS
+
+setClass("AddDoubleRule", contains="DoubleRule",S3methods=TRUE)
+
+setMethod("calculateSpecific",signature(x="AddDoubleRule", y="numeric", z="numeric"),
+ function(x,y,z){
+ return(y+z)
+ })
+
+#[2] MULTIPLY TWO PREVIOUS EXPRESSIONS
+
+setClass("MultDoubleRule",contains="DoubleRule",S3methods=TRUE)
+
+
+setMethod("calculateSpecific",signature(x="MultDoubleRule", y="numeric", z="numeric"),
+ function(x,y,z){
+ return(y*z)
+ })
+
+# #[3] SUBSTRACT TWO PREVIOUS EXPRESSIONS
+#
+# setClass("SubsDoubleRule",contains="DoubleRule",S3methods=TRUE)
+#
+#
+# setMethod("calculateSpecific",signature(x="SubsDoubleRule", y="numeric", z="numeric"),
+# function(x,y,z){
+# return(y-z)
+# })
+
+#[4] DIVIDING TWO NUMBERS (Philipp)
+#prevent from dividing by zero !!!
+#
+# setClass("DivDoubleRule",contains="DoubleRule",S3methods=TRUE)
+#
+# setMethod("calculateSpecific",
+# signature(x="DivDoubleRule", y="numeric", z="numeric"),
+# function(x,y,z){
+# if(z!=0){return(y%/%z)
+# }else{return(0)}})
+#
+# #[5] MODULO (Philipp)
+#
+# setClass("ModuloDoubleRule",contains="DoubleRule",S3methods=TRUE)
+#
+# setMethod("calculateSpecific",
+# signature(x="ModuloDoubleRule", y="numeric", z="numeric"),
+# function(x,y,z){
+# return(y%%z)
+# })
+
+# #[6] EXPONENTIAL FUNCTION (Philipp)
+# setClass("ExpDoubleRule", contains="DoubleRule",S3methods=TRUE)
+#
+# setMethod("calculateSpecific",
+# signature(x="ExpDoubleRule", y="numeric", z="numeric"),
+# function(x,y,z){
+# return(y^z)
+# })
+
+
+
+#EXECUTING RULES OPERATING ON TWO ARGUMENTS
+
+
+setMethod("calculate",signature(x="DoubleRule", y="numeric", z="numeric"),
+ function(x, y, z){
+ firstArg <- y #first element of the sequence
+ secondArg <-z #second element of the sequence
+
+ 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
+ }
+
+ result<-calculateSpecific(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)
+
+ })
+
+
+
+#--------------------------------------------------------------------------------------------------------------------
+#----------------------------------------------------generating sequences--------------------------------------------
+#--------------------------------------------------------------------------------------------------------------------
+
+#a list of single rules
+singleRules<-list("IdenSingleRule","AddConstSingleRule","MultConstSingleRule","DigSumSingleRule")#,"NegativeSingleRule")
+
+
+#a list of double rules
+doubleRules<-list("AddDoubleRule","MultDoubleRule")#,"DivDoubleRule","ModuloDoubleRule")#"ExpDoubleRule")
+
+
+
+#A FUNCTION TO CREATE SINGLE RULES
+# 'a1' is an index from table SingleRule (default a=NULL) //if 'a' is NULL it will be generated
+# 'n' how many rules are to be nested (default=NULL menas that I want to generate it automatically let's say from c(0,1,2)
+# n=0 would mean that I want to create just one rule with nothing nested inside)
+# 'cv1' is a constant value
+# '...' if I would like to add some rules nested I can provide their parameters cv must be always supplied #9even if the function doesn't require that
+
+createSR<-function(a1=NULL,cv1=NULL,n=NULL,...){
+ p<-list(...)#arguments for nesting other functions
+ p<-unlist(p)
+
+
+ if(is.null(a1)) {a1<-sample(2:length(singleRules),1)} #generate 'a' if no is supplied (we don't want to generate a=1 because it is identical function)
+ if(is.null(cv1)) {cv1<-sample(-100:100,1)} # generate a constant value if no is supplied
+ if(is.null(n)){n<-sample(c(0,1,2),1,prob=c(3/6,2/6,1/6)) #nesting more than two rules would be impossible to guess
+ k<-1:length(singleRules) #preventing nesting the same rules of the same class together
+ r<-sample(k[-a1],n,replace=FALSE)#generating rules to be nested
+ co<-sample(1:100,n) # generating constant values for nested rules
+ p<-as.vector(rbind(r,co))
+
+ } # generate 'n' if it is set as null with different probabilities
+
+
+ if("constantVal"%in%slotNames(singleRules[[a1]])){m<-new(singleRules[[a1]],constantVal=cv1,previousRule=new("IdenSingleRule"))
+ }else{m<-new(singleRules[[a1]],previousRule=new("IdenSingleRule"))}
+
+ if(n!=0) {k<-createSR(p[[1]],p[[2]],n-1,p[-c(1,2)])
+ m at previousRule<-k}#else{m at previousRule<-new("IdenSingleRule")}
+
+ return(m)
+}
+
+
+# A FUNCTION TO COMBINE DOUBLE RULES - it generates all parameters automatically
+
+
+# #preventing from more than one adding constant rule to be applied
+# # 'dr' - double rule (string)
+# redundancy_ch<-function(fr,sr,ns,a){
+# if(a==1) dr="AddConstSingleRule"
+# if(a==2) dr="MultConstSingleRule"
+#
+# b<-list(fr,sr,ns)
+# vec<-vector(mode="list",length=length(b))
+# for(i in 1:length(b))vec[i]<-inherits(b[[i]],dr) #list of logical values
+#
+# redundancy<-exact[vec==TRUE] #showing exact elements inherit from class "AddConstSingleRule"
+# length_red<-length(redundancy)
+# if(length_red>=2){b[[redundancy[length_red]]]<-sample(c(createSR(),new("IdenSingleRule")),1,prob=c(0.3,0.7))[[1]]
+# fr<-b[[1]];sr<-b[[2]];ns<-b[[3]];a=a
+# redundancy_ch(fr,sr,ns,a)
+# }else{return(b)}
+#
+#
[TRUNCATED]
To get the complete diff run:
svnlook diff /svnroot/ruler -r 51
More information about the Ruler-commits
mailing list