[Ruler-commits] r57 - pkg/ruleR/R
noreply at r-forge.r-project.org
noreply at r-forge.r-project.org
Tue Oct 9 22:38:11 CEST 2012
Author: merysionek
Date: 2012-10-09 22:38:10 +0200 (Tue, 09 Oct 2012)
New Revision: 57
Modified:
pkg/ruleR/R/ruleR_upgraded_final.R
Log:
added new class "IntertwinedRule" - different ru;es for odd and for even elements of numeric sequence, changing function sequenceR into method doing different operations for objects of different class - NOT YET CHANGED IN THE DOCUMENTATION
Modified: pkg/ruleR/R/ruleR_upgraded_final.R
===================================================================
--- pkg/ruleR/R/ruleR_upgraded_final.R 2012-10-09 15:31:14 UTC (rev 56)
+++ pkg/ruleR/R/ruleR_upgraded_final.R 2012-10-09 20:38:10 UTC (rev 57)
@@ -1,879 +1,879 @@
-#-------------------------------------------------------------------------------------------
-#------------------------------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){
- if(length(y) == 1){return(sum(digits(y))) ## only for one argument
- }else{
- return(unlist(lapply(digits(y),sum))) ## properly vectorized
- }
- })
-
-#[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)}
-#
-#
-# }
-
-
-
-# '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 doubleRules is shorter 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
-
- a<-doubleRules[[a]]
-
-
- p<-new(a,firstRule=fr, secondRule=sr,nextSingle=ns)
-
- return(p)
-
- }
-
-
-#A FUNCTION TO GENERATE NUMERIC SEQUENCE OF DECLARED LENGTH
-# 'seqlen' is the length of the numeric sequence (default value is 6)
-# 'start' - range from which starting values are generated
-sequenceR<-function(start,rule,seqlen, random = TRUE){
- if(seqlen<4) stop("sequence must be longer than 4")
-
-
- if(length(start)==1){ #generating starting elements of numeric sequence
- x1<-start;x2<-start
- }else{
- if(random){
- start<-sample(start,2)
- x1<-start[1]
- x2<-start[2]
- }else{
- x1<-start[1]
- x2<-start[2]
- }
- }
-
-
-
- k<-list()
- k[1]=x1
-
-
-
- if(inherits(rule,"SingleRule")){
- for(i in 2:seqlen){
- k[i]<-calculate(x=rule,y=k[[i-1]])
- }
-
- }else{
- k[2]=x2
- for(i in 3:seqlen){
- 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(x){
-
- if(length(x)%%2==1){m<-length(x)-1}else{m=length(x)}
-
- for(j in 1:(m/2-1)){
- if(identical(x[c((m-j):m)],x[c((m-2*j-1):(m-j-1))])){return(0);break
- }else{if(x[[m]]==x[[m-1]])return(0);break}
- }
-
- return(1)}
-
-
-
-#--------------------------------------------------------------------------------------------------------------------------------
-#---------------------------------------- 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<-sequenceR(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)}
-
- }
-
-
-#-----------------------------------------------------------------------------------------------------------------------------------------------
-#------------------------------------------------NEW APPROACH---------------------------------------------------------------------------------
-#-----------------------------------------------------------------------------------------------------------------------------------------------
-
-# 'range' of constant value user want to use (it can be a vector (ex. sequence with min value, max value and step))
-
-setClass("DictionaryRule",representation(rule="Rule",range="vecORnull"),S3methods=TRUE)
-
-
-setClassUnion(name="Rule", members=c("SingleRule","DoubleRule"))
-setClassUnion(name="vecORnull", members=c("vector","NULL"))
-
-#make a list of objects of class DirectRules and send the list to createItems function and name it as you wish
-
-#'range' for constant Value parameter// can be a vector ie. seq(3,5,by=.1) or a single numeric value
-#'index' - index of the rule in the basic rules list - it can be a list or a simple element
-
-createDictRule<-function(index,range=c(-15:-1,1:15)){
- if(inherits(index,"SingleRule")){rule<-index;if("constantVal"%in%slotNames(index)){range=index at constantVal}else{range=NULL}}
- if(inherits(index,"DoubleRule")){rule<-index;range=NULL}
- if(class(index)=="numeric"){#you specify rule from the table c(singleRules,doubleRules)
-
- if(index>length(c(singleRules,doubleRules)))stop("supplied index is larger than available list of rules")
-
- if(index<=length(singleRules)){
- rule<-createSR(a1=index,cv1=0,n=0,previousRule=new("IdenSingleRule")) #create a singleRule
- }else{rule<-createDR(a=(index-length(singleRules)),
- fr=new("IdenSingleRule"),
- sr=new("IdenSingleRule"),
- ns=new("IdenSingleRule"))
- range=NULL}#create a double rule basing on index value
-
- }
- range=as.vector(range)
- b<-new("DictionaryRule", rule=rule, range=range)
- return(b)
- }
-
-
-
-
-#FUNKCJE POMOCNICZE
-
-#GENERATE CV - function generating a constant value out of a given range
-#function generatin constantVal for singleRules from specyfied range
-#'x' an object of class DictionaryRule
-generate_cv<-function(x){
- if(length(x at range)==1)x at range<-rep(x at range,2)
- cv<-sample(x at range,1)
- return(cv)}#generating a constant Value for the first rule (if it needs one)
-
-
-
-
-#NEST - function nesting rules
-#'chain' - how many rules I am allowed to nest
-#'dict_single' - a list of available singleRules
-#'a' exterior rule - object of class SingleRule
-
-nest<-function(chain,dict_single,a){
-
- # if you want to nest more functions than there are available in dict_single list
- if(chain>length(dict_single))chain<-length(dict_single)
-
- if(chain!=0){
- p<-sample(1:length(dict_single),1)
- k<-dict_single[[p]]@rule
- if("constantVal"%in%slotNames(k))k at constantVal<-generate_cv(dict_single[[p]])
- a at previousRule<-k
- chain=chain-1
- dict_single<-dict_single[-p] #there is no point on nesting several same singleRules
-
- k<-nest(chain,dict_single,k)
- a at previousRule<-k
- }
- return(a)
-}
-
-
-#SPLIT DICT - function getting a list of SingleRules
-#a function to split itemDictionary into
-#two list - first one containing only SingleRules and the second only doubleRules
-#'type'=1 singlerules, type=2 doubleRules
-split_dict<-function(itemDictionary,type){
-
- lista<-list()
-
- if(type==1){b<-"SingleRule"}else{b<-"DoubleRule"}
- for(i in 1:length(itemDictionary)){
- if(inherits(itemDictionary[[i]]@rule,b))lista<-c(lista,itemDictionary[[i]])
-
- }
- return(lista)
-}
-
-
-
-#GENERATE RULE - function returning a rule form itemDictionary
-#'items' list of already generated items
-#'itemDictionary' list of objects of class "DictionaryRule" allowed in creating numeric sequence
-#'chain' showing how many rules I can combine
-#'del' which slots in doubleRules can be modyfied(1-only first,2-only second, 3-only next,c(1,2,3) all)
-#'start' - range for starting values that user can specify (it can be a single value or a vector specifying the range)
-
-generateRule<-function(itemDictionary,chain,del){
- if(class(itemDictionary)!="list")stop("itemDictionary must be of class 'list'")
-
- h<-sample(1:length(itemDictionary),1)#generate index of a rule of itemDictionary list
- a<-itemDictionary[[h]]@rule #craeting the outer singleRule
-
-
- #if we are dealing with single rules
- if(inherits(a,"SingleRule")){ #if the first generated rule is of class SingleRule
-
- if("constantVal"%in%slotNames(a)){
- cv<-generate_cv(itemDictionary[[h]])
- a at constantVal<-cv #generating a constant value for the outer rule
- }
- itemDictionary<-itemDictionary[-h]#nesting the same singleRules doesn't make sense so remove the rule from the list
-
-
- if(length(itemDictionary)>0){dict_single<-split_dict(itemDictionary,1)
- a<-nest(chain,dict_single,a)
- }else{dict_single<-NULL
- a<-a}
-
-
-
-
- }else{#if we are dealing with Double Rules
-
- chain0<-chain
- dict_single0<-split_dict(itemDictionary,1)
-
- if(1%in%del){chain<-chain0
- dict_single<-dict_single0
- h<-sample(1:length(dict_single),1)#generate index of a rule of itemDictionary list
- b<-dict_single[[h]]@rule #first nested function
- if("constantVal"%in%slotNames(b))b at constantVal<-generate_cv(dict_single[[h]])
- dict_single<-dict_single[-h]
- chain=chain-1
- if(chain>=1){a at firstRule<-nest(chain,dict_single,b)}else{a at firstRule<-b}
- }
-
-
-
- if(2%in%del){chain<-chain0
- dict_single<-dict_single0
- h<-sample(1:length(dict_single),1)#generate index of a rule of itemDictionary list
- b<-dict_single[[h]]@rule #first nested function
- if("constantVal"%in%slotNames(b))b at constantVal<-generate_cv(dict_single[[h]])
- dict_single<-dict_single[-h]
- chain=chain-1
- if(chain>=1){a at secondRule<-nest(chain,dict_single,b)}else{a at secondRule<-b}
- }
-
- if(3%in%del){chain<-chain0
- dict_single<-dict_single0
- h<-sample(1:length(dict_single),1)#generate index of a rule of itemDictionary list
- b<-dict_single[[h]]@rule #first nested function
- if("constantVal"%in%slotNames(b))b at constantVal<-generate_cv(dict_single[[h]])
- dict_single<-dict_single[-h]
- chain=chain-1
- if(chain>=1){a at nextSingle<-nest(chain,dict_single,b)}else{a at nextSingle<-b}
- }
-
-
-
- }
- return(a)
-}
-
-
-
-#CHECK - function checking if generated sequence is constant, or has elements greater/smaller than the limit
-#'result' - numeric sequence that I want to check
-#function would check for duplicates, constant/cyclic
-#I compare result with elements of list items that have the same length as 'result'
-# 'element_range' maximum and minimum values of elements of the numeric sequence
-
-check<-function(items,result,element_range){
- if(class(items)!="list")stop("items must be a list")
- max_val<-max(element_range)
- min_val<-min(element_range)
-
- #getting elements of list 'items' that have the same length as 'result'
- to_compare<-list()
-
- for(i in 1:length(items)){
- if(length(items[[i]])==length(result))to_compare<-c(to_compare,items[i])
- }
-
- if(length(to_compare)!=0){to_compare<-matrix(unlist(to_compare),length(to_compare),length(result),byrow=TRUE)
- }else{to_compare<-matrix(NA,1,length(result))}
-
-
-
- if(any(is.na(result))|| max(unlist(result))>max_val || min(unlist(result))< min_val||conCheck(result)==0 ||duplicate(to_compare,unlist(result))){
- return(0)}else{return(1)}
-
-}
-
-
-
-
-
-# VALIDATION FUNCTION - function saving new items on a list if they are unique and not constant etc.
-#'seqlen' - length of numeric sequence
-#items' list of already generated items
-#'itemDictionary' objects of class "DictionaryRule" allowed in creating numeric sequence
-#'chain' showing how many rules I can combine
-#'del' which slots in doubleRules can be modyfied(1-only first,2-only second, 3-only next,c(1,2,3) all)
-#'start' - range for starting values that user can specify (it can be a single value or a vector specifying the range)
-#'number'-iteration counter
-
-
-val<-function(items,rules,itemDictionary,chain,del,start,element_range,seqlen,number){
-
- number=number
-
- rule<-generateRule(itemDictionary,chain,del)
- result<-sequenceR(start=start,rule=rule,seqlen=seqlen)[[1]]
-
-
- validation<-check(items,result,element_range)
-
-
-
-if(validation==0){#if the sequence is not unique, tru generating another one (but max. for three times)
-
-
- if(number<3) {number=number+1
- val(items=items,rules=rules,itemDictionary=itemDictionary,chain=chain,del=del,start=start,element_range=element_range,seqlen=seqlen,number)
- }else{item<-rep(NA,seqlen)
- rule<-new("IdenSingleRule")
-
- k<-list(item,rule)
- return(k)
- break
-
- } # if you failed to generate a unique sequence in 3 attempts- return zero sequence
- }else{item<<-unlist(result)
-
- rule<-rule
- k<-list(item,rule)
- return(k)
- break
- }
-
-
-}
-
-
-
- #'n'- how many items would you like to create
- #'seqlen' - how long would you like your items to be (you can specify different length for every item)
- #'dictionary' - dictionary of rules user would like to use in generating new sequences
- #'chain' - how many rules you want to combine - it can be a range, a list of ranges or a single value
- #'del'- how many of DoubleRule slots I can change
- #'start' - range for starting values that user can specify (it can be a single value or a vector specifying the range)
- #'exact' - which dictionary rules can be applied
- #'element_range' - the range of elements - should be a vector of length 2 specyfying max and min approved element
-
-basicDictionary<-list(createDictRule(2),createDictRule(3),createDictRule(4),createDictRule(5),createDictRule(6))#,createDictRule(7))#,createDictRule(8),createDictRule(9))
-
-
-
-createTest<-function(n,dictionary=basicDictionary,start=1:100,chain=2,del=c(1,2,3),seqlen=6,exact=NULL,element_range=c(-1000,1000)){
- if(class(dictionary)!="list")stop("dictionary must be a list")
-
- if(is.null(exact)){exact0<-rep(list(1:length(dictionary)),length.out=n)
- }else{if(class(exact)=="list"){exact0<-exact}else{exact0<-rep(list(exact),length.out=n)}}
-
- if(class(start)=="list"){start0<-start}else{start0<-rep(list(start), length.out=n)}
- if(class(chain)=="list"){chain0<-chain}else{chain0<-rep(list(chain), length.out=n)}
- if(class(del)=="list"){del0<-del}else{del0<-rep(list(del), length.out=n)}
- if(class(seqlen)=="list"){seqlen0<-seqlen}else{seqlen0<-rep(list(seqlen), length.out=n)}
- if(class(element_range)=="list"){element_range0<-element_range}else{element_range0<-rep(list(element_range), length.out=n)}
-
-
- items<-list(NA) #I will store generated items in a matrix
- rules<- list(NA)
-
- for(i in 1:n){
- exact<-exact0[[i]]
-
- start<-start0[[i]]
- chain<-chain0[[i]]
- del<-del0[[i]]
- seqlen<-seqlen0[[i]]
- element_range<-element_range0[[i]]
-
- itemDictionary<-dictionary[exact] #list of dictionary rules allowed in generating an item
-
-
- m<-val(items=items,rules=rules,itemDictionary,chain,del,start,element_range,seqlen,number=0)
-
- items[[length(items)+1]]<-m[[1]]
- rules[[length(rules)+1]]<-m[[2]]
-
- }
- return(list(items[-1],rules[-1]))
- }
-
-#=====PRINTING RULES=================================================================================================================
-
-
-ws<-function(x){
-
- if(inherits(x,"AddConstSingleRule")){
- a1="Add"
- b1=x at constantVal
- }
- if(inherits(x,"MultConstSingleRule")){a1="Multiply the previous element of numeric sequence by"
- b1=x at constantVal
- }
- if(inherits(x,"DigSumSingleRule")){ a1="Take sum of digits"
- b1=NULL
- }
-
- if(inherits(x,"NegativeSingleRule")){a1= "Take a negative of the element"
[TRUNCATED]
To get the complete diff run:
svnlook diff /svnroot/ruler -r 57
More information about the Ruler-commits
mailing list