#<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<< intersect4interval <- function(int1,int2) #TITLE computes the interval intersection of two intervals #DESCRIPTION # computes and returns the interval (vector of length 2 or 0) # which is the intersection of two given intervals.\cr # Null intervals are indicated by \code{rbsb.num0}. #DETAILS #KEYWORDS misc #INPUTS #{int1} <> #{int2} <> #[INPUTS] #VALUE # A numeric(2) or numeric(0) providing the intersection of the # two input intervals. #EXAMPLE # rbsb3k("RESET"); # needed only for R checking, to be forgotten # intersect4interval(numeric(0),1:2); # intersect4interval(c(1,10),c(-3,5)); # intersect4interval(c(1,10),c(10,12)); # intersect4interval(c(1,10),c(11,12)); #REFERENCE #SEE ALSO #CALLING #COMMENT #FUTURE #AUTHOR J.-B. Denis #CREATED 10_11_17 #REVISED 10_12_13 #-------------------------------------------- { # checking l1 <- length(int1); l2 <- length(int2); if (rbsb.mck) { if (!(l1 %in% c(0,2))) { erreur(int1,"This is not an interval: numeric(0) or numeric(2) expected"); } if (!(l2 %in% c(0,2))) { erreur(int2,"This is not an interval: numeric(0) or numeric(2) expected"); } if (l1 == 2) { if (diff(int1) < 0) { erreur(int1,"This is not an interval: lower > upper"); } if (is.nan(diff(int1))) {erreur(int1,"This is not an accepted interval");} } if (l2 == 2) { if (diff(int2) < 0) { erreur(int1,"This is not an interval: lower > upper"); } if (is.nan(diff(int2))) {erreur(int2,"This is not an accepted interval");} } } # degenerate case if (l1*l2 == 0) { return(numeric(0));} # null cases if ((int1[2] < int2[1])|(int2[2] < int1[1])) { return(numeric(0));} # returning res <- c(max(int1[1],int2[1]),min(int1[2],int2[2])) res; } #>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>> #<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<< belong2interval <- function(x,int) #TITLE checks if a series of values belong to a series of intervals #DESCRIPTION # computes and returns the indicator vector of the positions of # values with respect to intervals. #DETAILS # This function is compatible with real infinite values #KEYWORDS misc #INPUTS #{x} <> #{int} <> #[INPUTS] #VALUE # A matrix with rows associated to the \code{x} values and # columns associated to the \code{int} intervals giving # \code{-2,-1,0,1,2} according to whether \code{x} is less than, # equal to the lower bound, inside, equal to the upper bound or # greater than the interval. #EXAMPLE # rbsb3k("RESET"); # needed only for R checking, to be forgotten # belong2interval(1:5,1:2); # belong2interval(1:5,matrix(1:10,ncol=2)); #REFERENCE #SEE ALSO #CALLING #COMMENT #FUTURE #AUTHOR J.-B. Denis #CREATED 10_11_17 #REVISED 10_12_13 #-------------------------------------------- { # checking if (rbsb.mck) { check4tyle( x,rbsb.numer,-1,message=" 'x' must be numeric"); check4tyle(int,rbsb.numer,-1,message="'int' must be numeric"); if (!is.matrix(int)) { if (length(int) != 2) { erreur(int,"When 'int' is not a matrix, it must be a numeric(2)"); } if (is.nan(diff(int))) {erreur(int,"This is not an accepted interval");} if (diff(int)<0) { erreur(int,"'int' does not define an interval!");} } else { if (ncol(int)!=2) { erreur(int,"When 'int' is a matrix, it must comprise 2 columnes"); } ru <- int[,2] - int[,1]; if (any(is.nan(ru))) { erreur(int,"Some rows are not accepted as intervals");} if (any((ru<0))) { erreur(int,"Not all rows of 'int' define an interval"); } } } # getting a uniform presentation if (!is.matrix(int)) { int <- matrix(int,ncol=2);} # preparing the result nbx <- length(x); nbint <- nrow(int); res <- matrix(NA,nbx,nbint); dimnames(res) <- list(names(x),dimnames(int)[[1]]); # degenerate case if (length(res)==0) { return(res);} # ancillary functions be0 <- function(x,int0) { if (is.finite(int0)) { ss <- sign(x-int0); } else { ss <- rep(-sign(int0),length(x)); ss[x==int0] <- 0; } ss; } bel <- function(x,int) { be0(x,int[1]) + be0(x,int[2]); } # computation for (ii in bc(nrow(int))) { res[,ii] <- bel(x,int[ii,]); } # returning res; } #>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>> #<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<< find8candidates <- function(X,vari=NULL,mima=NULL, crit=NULL,retour=NULL) #TITLE looks for non dominated candidates #DESCRIPTION # Looks for the subset of rows of \code{X} such that # for all the designated columns these individuals # are not dominated by another row. Row {a} is dominated # by row \code{b}, when \code{X[a,j] > X[b,j]} for all # designated \code{j}. #DETAILS # The dominance is strict, so two equivalent candidates will be # both retained. #KEYWORDS #PKEYWORDS #INPUTS #{X} << The matrix (or data.frame) the rows of which have to be # considered.>> #[INPUTS] #{vari} << when \code{NULL} all columns must be considered, # if not the designation of the columns.>> #{mima} << when \code{NULL} no bound is given. # If not must be a vector of the exact size of \code{vari} # (after expansion when \code{is.null(vari)}) containing # the upper (lower when \code{!is.null(crit)} limits # for acceptable values; with the convention that # \code{NA} means no limit for the corresponding # column.>> #{crit} << when \code{NULL} less is better, if not greater is.>> #{retour} << when \code{NULL} the number of non-dominated rows # is returned, if not \code{X} restricted to these # rows.>> #VALUE # A vector of the selection of rows, or a matrix or a data.frame. #EXAMPLE # set.seed(12345); # uu <- matrix(round(100*runif(40)),20); # print(uu); # print(rbind(uu[find8candidates(uu ),])); # print(rbind(uu[find8candidates(uu,mima=c(NA,50)),])); #REFERENCE #SEE ALSO #CALLING #COMMENT #FUTURE #AUTHOR J.-B. Denis #CREATED 11_03_11 #REVISED 11_03_28 #-------------------------------------------- { cat("Verifier que cette fonction est bien la derniere version de modif.r de bc07\n"); # # some checking and preparation of constants # if (rbsb.mck) { check4tyle(X,c("matrix","data.frame"),-1,message="find8candidates: X not accepted"); } if (is.null(vari)) { vari <- 1:ncol(X);} if (rbsb.mck) { if (!is.null(mima)) { if (length(mima) != length(vari)) { erreur(list(mima,vari),"find8candidates: 'mima' not of the right length"); } } } # # At first every row can be a candidate can <- rep(TRUE,nrow(X)); # and no one is retained res <- numeric(0); # # taking care of the possible limits if (!is.null(mima)) { for (jco in bf(vari)) { if (!is.na(mima[jco])) { if (is.null(crit)) { can <- can & (X[,vari[jco]] <= mima[jco]); } else { can <- can & (X[,vari[jco]] >= mima[jco]); } } } } # while (sum(can) > 0) { # some new candidate can be found sco <- apply(X[can,vari,drop=FALSE],1,sum); if (is.null(crit)) { ro0 <- which(min(sco)==sco)[1]; } else { ro0 <- which(max(sco)==sco)[1]; } # corresponding row number of X nca <- (1:nrow(X))[can][ro0]; # keeping this candidate and removing it from the list res <- c(res,nca); can[nca] <- FALSE; # removing from the candidate list # all of them dominated by this new retained xxx <- X[nca,vari]; for (ii in bc(nrow(X))) { if (can[ii]) { delta <- X[ii,vari] - xxx; if (is.null(crit)) { if (all(delta > 0)) { can[ii] <- FALSE;} } else { if (all(delta < 0)) { can[ii] <- FALSE;} } }} } # in case a data frame must be returned if (!is.null(retour)) { res <- X[res,,drop=FALSE]; } # # returning res; } #>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>> #<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<< ijk2n <- function(ii,di) #TITLE transforms a series of indices into a unique index #DESCRIPTION # \code{ii[k]} is supposed to be a value in \code{1:di[k]}, # this function returns the global index obtained by # running the nested loops \code{ii[k]}. #DETAILS # The reverse computation is done by \code{n2ijk} #KEYWORDS #PKEYWORDS #INPUTS #{ii} <> #{di} <> #[INPUTS] #VALUE # a positive integer #EXAMPLE # for (i1 in 1:4) { for (i2 in 1:2) { for (i3 in 1:3) { # print(c(i1,i2,i3,ijk2n(c(i1,i2,i3),c(4,2,3)))); # }}} #REFERENCE #SEE ALSO n2ijk #CALLING #COMMENT #FUTURE #AUTHOR J.-B. Denis #CREATED 11_03_23 #REVISED 11_03_23 #-------------------------------------------- { # # some checking # if (rbsb.mck) { check4tyle(ii,rbsb.numer,c(0,Inf),c(1,Inf),"'ii' not accepted"); check4tyle(di,rbsb.numer,c(0,Inf),c(1,Inf),"'di' not accepted"); if (length(ii) != length(di)) { erreur(list(ii,di),"'ii' and 'di' are supposed with equal lengths"); } if (!all(ii<=di)) { erreur(list(ii,di),"'ii' cannot be greater than 'di'"); } } # # computing KK <- length(di); if (KK > 0) { res <- ii[KK]; for (kk in bc(KK-1)) { res <- res + (ii[kk]-1) * prod(di[(kk+1):KK]); } } else { res <- 0; } # # returning res } #>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>> #<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<< n2ijk <- function(n,di) #TITLE transforms a unique index into a series of indices #DESCRIPTION # From a global index obtained by # running the nested loops \code{ii[k]} returns # \code{ii[k]} supposed to be a value in \code{1:di[k]} #DETAILS # The reverse computation is done by \code{ijk2n} #KEYWORDS #PKEYWORDS #INPUTS #{n} <> #{di} <> #[INPUTS] #VALUE # a vector of same size as \code{di} #EXAMPLE # for (n in 1:24) { # print(c(n,n2ijk(n,c(4,2,3)))); # } #REFERENCE #SEE ALSO ijk2n #CALLING #COMMENT #FUTURE #AUTHOR J.-B. Denis #CREATED 11_03_23 #REVISED 12_05_16 #-------------------------------------------- { # # some checking # if (rbsb.mck) { check4tyle(n,rbsb.numer,c(0,1),c(1,Inf),"'n' not accepted"); check4tyle(di,rbsb.numer,c(0,Inf),c(1,Inf),"'di' not accepted"); if (n > prod(di)) { erreur(list(n,di),"'n' is too great with respect to 'di'"); } } # # computing KK <- length(di); if (KK > 0) { res <- rep(NA,KK); for (kk in bc(KK-1)) { res[kk] <- 1 + (n-1) %/% prod(di[(kk+1):KK]); n <- n - (res[kk]-1)*prod(di[(kk+1):KK]); } res[KK] <- n; } else { res <- numeric(0); } # # returning res } #>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>> #<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<< print8plana <- function(plana,indent=" ") #TITLE checks / prints a \code{plana} list #DESCRIPTION # checks and/or prints in an understandable way the different # components of a \code{plana} list. See the description # of this argument for the details. #DETAILS # #KEYWORDS #PKEYWORDS #INPUTS #{plana} <> #[INPUTS] #{indent} << # A single character to use before the printing # (for instance to introduce a \code{#} when commenting # an output file.). # Another use of \code{indent} is that only checking is # wanted, which is indicated when the value is \code{CHECK}. # >> #VALUE # nothing a standard print is performed #EXAMPLE # print8plana(list(1,matrix(c(2,3,2,1,1,1),3,2),1),indent="CHECK"); # print8plana(list(1,matrix(c(2,3,2,1,1,1),3,2),1)); # print8plana(list(1,matrix(c(2,3,2,1,1,1),3,2),1)); # print8plana(list( 2,matrix(c(3,2,2,1),2,2),list(LETTERS[1:3],letters[1:2])),"#"); # print8plana(list(-2,matrix(c(3,2,2,1),2,2),list(LETTERS[1:3],letters[1:2])),"#"); #REFERENCE #SEE ALSO #CALLING #COMMENT #FUTURE #AUTHOR J.-B. Denis #CREATED 11_03_22 #REVISED 11_03_23 #-------------------------------------------- { # # some checking # code <- plana[[3]]; if ((rbsb.mck)|identical(indent,"CHECK")) { check4tyle(plana,c("list"),3, message="print8plana: 'plana' not accepted"); check4tyle(plana[[1]],c("numeric"),1,c(-Inf,Inf), message="print8plana: 'plana[[1]]' not accepted"); check4tyle(plana[[2]],c("matrix"),-1, message="print8plana: 'plana[[2]]' not accepted"); if (ncol(plana[[2]]) != 2) { erreur(plana[[2]],"A matrix with two columns was expected"); } if (nrow(plana[[2]]) < plana[[1]]) { erreur(plana,"'plana' not compatible with the row number of plana[[2]]"); } if (!all((plana[[2]][,2]>0) &(plana[[2]][,2]<=plana[[2]][,1]))) { erreur(plana[[2]],"Some central points are not in the possible range"); } if (is.numeric(code)) { # 0 or 1 are expected check4tyle(code,"integer",1,c(0,1),"When 'numeric' code must be '0' or '1'"); } else { # a consistent list is expected check4tyle(code,"list",nrow(plana[[2]]),message="'code' not numeric and not the desired list"); for (rr in bc(nrow(plana[[2]]))) { if (length(code[[rr]]) != plana[[2]][rr,1]) { erreur(list(code,plana[[1]]), paste("For the factor number",rr,"'code' and 'plana[[2]]' disagree")); } } } # check4tyle(indent,c("character"),1,message="print8plana: 'indent' not accepted"); } # # only checking was desired if (identical(indent,"CHECK")) { return(invisible());} # # getting the constant ord <- plana[[1]]; if (ord > 0) { ord <- c(0,bc(ord));} else { ord <- abs(ord);} nbf <- nrow(plana[[2]]); cev <- plana[[2]][,2]; noms <- dimnames(plana[[2]])[[1]]; if(is.null(noms)) { noms <- bc(nbf); } # # printing cat(indent,"The order(s) of the /plana/ is(are)", paste(ord,collapse=":"), "\n"); cat(indent,"\n"); if (is.numeric(code)) { cat(indent,"The coding of the /plana/ starts from",code,"\n"); cat(indent,"\n"); } for (ff in bf(cev)) { cat(indent, "Factor (",noms[ff],"):",plana[[2]][ff,1],"levels;", "central level is",plana[[2]][ff,2],"; "); if (is.numeric(code)) { cat("\n"); } else { cat("with codes:",paste(code[[ff]],collapse="/"),"\n"); } } # # returning invisible(); } #>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>> #<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<< plana2matrix <- function(plana,rm.du=TRUE) #TITLE computes a /plana/ #DESCRIPTION # Returns the matrix with factors in columns # and the combination of its levels in rows. # Look at \code{print8plana} for more details. #DETAILS #KEYWORDS #PKEYWORDS #INPUTS #{plana} <> #[INPUTS] #{rm.du} << When TRUE, repetitions are removed.>> #VALUE # A matrix with as many columns as the factors, and as many # rows as asked combinations. #EXAMPLE # plana2matrix(list(1,matrix(c(2,3,2,1,1,1),3,2))); # plana2matrix(list(1,matrix(c(2,3,2,1,1,1),3,2))); # plana2matrix(list(2,matrix(c(3,2,2,1),2,2,dimnames=list(c("F1","F2"),NULL)),list(LETTERS[1:3],letters[1:2])); # plana2matrix(list(3,matrix(c(2,2,2,1,1,1),3,2))); # plana2matrix(list(3,matrix(c(2,2,2,1,1,1),3,2)),rm.du=FALSE); #REFERENCE #SEE ALSO #CALLING #COMMENT #FUTURE #AUTHOR J.-B. Denis #CREATED 11_03_22 #REVISED 11_03_22 #-------------------------------------------- { # checking if (rbsb.mck) { print8plana(plana,indent="CHECK"); } # # getting the constants code <- plana[[3]]; ord <- plana[[1]]; if (ord > 0) { ord <- c(0,bc(ord));} else { ord <- abs(ord);} nbf <- nrow(plana[[2]]); cev <- plana[[2]][,2]; noms <- dimnames(plana[[2]])[[1]]; if(is.null(noms)) { noms <- bc(nbf); } long <- plana[[2]][,1]; cent <- plana[[2]][,2]; # # computing the combinations # # initialization res <- matrix(NA,0,nbf); # different choosen orders for (oo in ord) { # central point if (oo == 0) { res <- rbind(res,cent); } else { # looping on the different subsets di <- rep(2,nbf); nn <- 2^nbf; for (n in bc(nn)) { ii <- n2ijk(n,di) - 1; if (sum(ii) == oo) { # this subset must be taken into account ff <- which(ii==1); # looping on its combinations ddd <- long[ff]; nnn <- prod(ddd); for (m in bc(nnn)) { jj <- n2ijk(m,ddd); xx <- cent; xx[ff] <- jj; res <- rbind(res,xx); } } } } } # # removing duplicates if (rm.du) { # coding each row coro <- apply(res,1,function(x){ijk2n(x,long);}) coun <- unique(coro); coou <- outer(coro,coun,"==")*bc(nrow(res)); coou[coou==0] <- Inf; coou <- apply(coou,2,min); if (length(coou)>0) { res <- res[coou,]; } } # # changing the coding if (is.numeric(code)) { # is the coding starting from 0 if (code==0) { res <- res - 1;} } else { # the coding is specific for (jj in bc(ncol(res))) { res[,jj] <- code[[jj]][as.numeric(res[,jj])]; } } # # returning if (!is.matrix(res)) { res <- matrix(res,1); } dimnames(res) <- list(NULL,noms); res; } #>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>