[Ruler-commits] r48 - in pkg: . ruleR/R
noreply at r-forge.r-project.org
noreply at r-forge.r-project.org
Mon Aug 27 16:11:57 CEST 2012
Author: merysionek
Date: 2012-08-27 16:11:57 +0200 (Mon, 27 Aug 2012)
New Revision: 48
Modified:
pkg/marices.R
pkg/ruleR/R/ruleR.R
Log:
deleted "SubsDoubleRules" because of being redundant.
You can transform the second element to be negative and add those two values.
adding constrians in createDR() - prohibiting in AddDoubleRules more than one single rule to be AddConstSingleRule, and in MultDoubleRule to be MultConstSingleRule
added new conditions in conCheck - preventing sequences with repeated 2 or 3 elements repeated ex. 1,5,8,,1,5,8
Modified: pkg/marices.R
===================================================================
--- pkg/marices.R 2012-08-27 10:08:31 UTC (rev 47)
+++ pkg/marices.R 2012-08-27 14:11:57 UTC (rev 48)
@@ -404,12 +404,31 @@
+#executing the rules from rule list
+#'direction' 1= columns, 2=rows
+# execute<-function(m,rules_to_apply, direction){
+#
+# for(i in 1:length(rules_to_apply[[direction]][[1]])){
+#
+# ind<-rules_to_apply[[direction]][[2]][[i]]
+# r<-rules_to_apply[[direction]][[1]][[i]]
+#
+# if(!is.null(r)){
+# for(j in ind) {m[[2]][[j]]<-calculate(x=r,y=m[[2]][[j]])
+# if("progression"%in%slotNames(r))r at parVal<-r at parVal+r@progression}
+# }
+# }
+# }
+
+
+
applyMatrixRules<-function(f,b,size,rulelist){}
setClassUnion("nullORnumeric", members=c("NULL", "numeric"))
setMethod("applyMatrixRules",signature(f="nullORnumeric",b="nullORnumeric",size="numeric", rulelist="MatrixRulesList"),
function(f,b,size,rulelist){
+
m<-firstMatrix(f,b,size) #list of pictures and their viepoints(generated randomly)
rules_to_apply<-schedule(size) # a list of rules to apply to particular rowsand columns (as default rule is NULL)
@@ -424,8 +443,10 @@
rules_to_apply[[direction]][[1]][[which]]<-rule
}
+
+# execute(m,rules_to_apply,direction=1) #executing rules for columns
+# execute(m,rules_to_apply,direction=2) #executing rules for rows
-
#executing rules for columns
for(i in 1:length(rules_to_apply[[1]][[1]])){
ind<-rules_to_apply$column$col_index[[i]]
@@ -470,9 +491,7 @@
return(m)
-
-
-
+
})
Modified: pkg/ruleR/R/ruleR.R
===================================================================
--- pkg/ruleR/R/ruleR.R 2012-08-27 10:08:31 UTC (rev 47)
+++ pkg/ruleR/R/ruleR.R 2012-08-27 14:11:57 UTC (rev 48)
@@ -143,16 +143,16 @@
return(y*z)
})
-#[3] SUBSTRACT TWO PREVIOUS EXPRESSIONS
+# #[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)
+# })
-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)
@@ -220,7 +220,7 @@
#a list of double rules
-doubleRules<-list("AddDoubleRule","MultDoubleRule","SubsDoubleRule","DivDoubleRule","ModuloDoubleRule","ExpDoubleRule")
+doubleRules<-list("AddDoubleRule","MultDoubleRule","DivDoubleRule","ModuloDoubleRule","ExpDoubleRule")
@@ -261,6 +261,29 @@
# 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
@@ -271,16 +294,22 @@
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]]
-
+
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(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)
@@ -345,7 +374,12 @@
m<-length(seq)
- if(identical(seq[m],seq[m-1]) && identical(seq[m],seq[m-2]) ) {return(0)} else {return(1)}
+ 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)
}
More information about the Ruler-commits
mailing list