R Under development (unstable) (2019-03-18 r76245) -- "Unsuffered Consequences" Copyright (C) 2019 The R Foundation for Statistical Computing Platform: x86_64-pc-linux-gnu (64-bit) R is free software and comes with ABSOLUTELY NO WARRANTY. You are welcome to redistribute it under certain conditions. Type 'license()' or 'licence()' for distribution details. Natural language support but running in an English locale R is a collaborative project with many contributors. Type 'contributors()' for more information and 'citation()' on how to cite R or R packages in publications. Type 'demo()' for some demos, 'help()' for on-line help, or 'help.start()' for an HTML browser interface to help. Type 'q()' to quit R. > pkgname <- "extracat" > source(file.path(R.home("share"), "R", "examples-header.R")) > options(warn = 1) > library('extracat') > > base::assign(".oldSearch", base::search(), pos = 'CheckExEnv') > base::assign(".old_wd", base::getwd(), pos = 'CheckExEnv') > cleanEx() > nameEx("BCC") > ### * BCC > > flush(stderr()); flush(stdout()) > > ### Name: BCC > ### Title: The Bertin Classification Criterion > ### Aliases: BCC > > ### ** Examples > > M <-arsim(1000, c(12,12), 3) > BCC(M) [1] 163049 > > M2 <- optile(M, iter = 100) > BCC(M2) [1] 44419 > > > > > > > cleanEx() > nameEx("BCI") > ### * BCI > > flush(stderr()); flush(stdout()) > > ### Name: BCI > ### Title: The Bertin Classification Index > ### Aliases: BCI > > ### ** Examples > > #for an unoptimized matrix we take the minimum of BCI(M) and BCI(M[,12:1]) > M <-arsim(1000, c(12,12), 3) > min(BCI(M), BCI(M[,12:1])) [1] 0.8135658 > > #an strongly related alternative (for two-way data) > kendalls(M) [1] 0.1856459 > > M2 <- optile(M, iter = 100) > BCI(M2) [1] 0.2216375 > kendalls(M2) [1] 0.7156287 > > M3 <-arsim(100000, c(12,13,15), 4,noise=0.2,shuffle=FALSE) > BCI(M3) [1] 0.4392663 > > > > > cleanEx() > nameEx("Burt") > ### * Burt > > flush(stderr()); flush(stdout()) > > ### Name: Burt > ### Title: Burt atrix > ### Aliases: Burt > > ### ** Examples > > require(MASS) Loading required package: MASS > Burt(housing) Sat:Low Sat:Medium Sat:High Infl:Low Infl:Medium Infl:High Sat:Low 567 0 0 282 206 79 Sat:Medium 0 446 0 170 189 87 Sat:High 0 0 668 175 264 229 Infl:Low 282 170 175 627 0 0 Infl:Medium 206 189 264 0 659 0 Infl:High 79 87 229 0 0 395 Type:Tower 99 101 200 140 172 88 Type:Apartment 271 192 302 268 297 200 Type:Atrium 64 79 96 95 84 60 Type:Terrace 133 74 70 124 106 47 Cont:Low 262 178 273 234 279 200 Cont:High 305 268 395 393 380 195 Type:Tower Type:Apartment Type:Atrium Type:Terrace Cont:Low Sat:Low 99 271 64 133 262 Sat:Medium 101 192 79 74 178 Sat:High 200 302 96 70 273 Infl:Low 140 268 95 124 234 Infl:Medium 172 297 84 106 279 Infl:High 88 200 60 47 200 Type:Tower 400 0 0 0 219 Type:Apartment 0 765 0 0 317 Type:Atrium 0 0 239 0 82 Type:Terrace 0 0 0 277 95 Cont:Low 219 317 82 95 713 Cont:High 181 448 157 182 0 Cont:High Sat:Low 305 Sat:Medium 268 Sat:High 395 Infl:Low 393 Infl:Medium 380 Infl:High 195 Type:Tower 181 Type:Apartment 448 Type:Atrium 157 Type:Terrace 182 Cont:Low 0 Cont:High 968 > th <- xtabs(Freq~Sat+Infl+Type, data = housing) > Burt(th) Sat:Low Sat:Medium Sat:High Infl:Low Infl:Medium Infl:High Sat:Low 567 0 0 282 206 79 Sat:Medium 0 446 0 170 189 87 Sat:High 0 0 668 175 264 229 Infl:Low 282 170 175 627 0 0 Infl:Medium 206 189 264 0 659 0 Infl:High 79 87 229 0 0 395 Type:Tower 99 101 200 140 172 88 Type:Apartment 271 192 302 268 297 200 Type:Atrium 64 79 96 95 84 60 Type:Terrace 133 74 70 124 106 47 Type:Tower Type:Apartment Type:Atrium Type:Terrace Sat:Low 99 271 64 133 Sat:Medium 101 192 79 74 Sat:High 200 302 96 70 Infl:Low 140 268 95 124 Infl:Medium 172 297 84 106 Infl:High 88 200 60 47 Type:Tower 400 0 0 0 Type:Apartment 0 765 0 0 Type:Atrium 0 0 239 0 Type:Terrace 0 0 0 277 > > > > > cleanEx() detaching ‘package:MASS’ > nameEx("CBCI") > ### * CBCI > > flush(stderr()); flush(stdout()) > > ### Name: CBCI > ### Title: The Conditional Independence Bertin Classification Index > ### Aliases: CBCI > > ### ** Examples > > ## Not run: > ##D A <- optile(arsim(10000, c(11,12,13), 4,0.1)) > ##D > ##D BCI(A) > ##D > ##D CBCI(A,1,TRUE) > ##D CBCI(A,1,FALSE) > ##D > ## End(Not run) > > > > cleanEx() > nameEx("CPScluster") > ### * CPScluster > > flush(stderr()); flush(stdout()) > > ### Name: CPScluster > ### Title: Clusterings for the US Current Population Survey. > ### Aliases: CPScluster > ### Keywords: datasets > > ### ** Examples > > data(CPScluster) > ## maybe str(CPScluster) ; plot(CPScluster) ... > > > > cleanEx() > nameEx("GSAC") > ### * GSAC > > flush(stderr()); flush(stdout()) > > ### Name: gsac > ### Title: GSAC > ### Aliases: gsac > > ### ** Examples > > ## Not run: > ##D > ##D ss <- sample(1:nrow(plants),500) > ##D M <- t( as.matrix(plants[ss,-1]) ) > ##D > ##D gs <- gsac(M, fun="IBCC", foreign=".Call") > ##D > ##D heattile(M, Is = getIs2(gs, dim(M)), fluct = TRUE, hm.palette = 1) > ## End(Not run) > > # simulated example: > > A <- arsim(3000,c(8,5),1) > B <- arsim(2000,c(7,6),1) > C <- arsim(4000,c(9,9),1) > M <- matrix(0,16,16) > > M[1:8,1:5] <- A > M[4:10,6:11] <- B > M[8:16,8:16] <- C > > M <- as.table(optile(M, iter=20)) > t0 <- 0.6 > > # no subtable reordering > test1 <- gsac(M,resort="none",method= "BCI", tau0=t0) > > require(scales) Loading required package: scales > heattile(M,Is=test1,hm.palette=alpha(1,0.8),shape="r", + fluct = TRUE, label = c(TRUE,TRUE),bg.col=NA, lab.opt = list(rot=c(0,90))) > > > ## Not run: > ##D # unrestricted subtable reordering > ##D test2 <- gsac(M,resort="s", method= "BCI", tau0=t0) > ##D > ##D #common reordering > ##D test3 <- gsac(M,resort="c", method= "BCI", tau0=t0) > ##D > ##D # clusters do not share rows, columns, both > ##D test4 <- gsac(M,resort="s",force.cs=TRUE,method = "BCI", tau0=t0) > ##D test5 <- gsac(M,resort="s",force.rs=TRUE,method = "BCI", tau0=t0) > ##D test6 <- gsac(M,resort="s",force.rs=TRUE,force.cs=TRUE, tau0=t0) > ## End(Not run) > > > ## Not run: > ##D heattile(M,Is=test2,hm.palette=alpha(1,0.8),shape="r", > ##D fluct = TRUE, label = c(TRUE,TRUE),bg.col=NA, lab.opt = list(rot=c(0,90))) > ##D > ##D heattile(M,Is=test3,hm.palette=alpha(1,0.8),shape="r", > ##D fluct = TRUE, label = c(TRUE,TRUE),bg.col=NA, lab.opt = list(rot=c(0,90))) > ##D > ##D heattile(M,Is=test4,hm.palette=alpha(1,0.8),shape="r", > ##D fluct = TRUE, label = c(TRUE,TRUE),bg.col=NA, lab.opt = list(rot=c(0,90))) > ##D > ##D heattile(M,Is=test5,hm.palette=alpha(1,0.8),shape="r", > ##D fluct = TRUE, label = c(TRUE,TRUE),bg.col=NA, lab.opt = list(rot=c(0,90))) > ##D > ##D heattile(M,Is=test6,hm.palette=alpha(1,0.8),shape="r", > ##D fluct = TRUE, label = c(TRUE,TRUE),bg.col=NA, lab.opt = list(rot=c(0,90))) > ## End(Not run) > > > > > > cleanEx() detaching ‘package:scales’ > nameEx("GeneEx") > ### * GeneEx > > flush(stderr()); flush(stdout()) > > ### Name: GeneEx > ### Title: Gene Expression Data > ### Aliases: GeneEx > ### Keywords: datasets > > ### ** Examples > > data(GeneEx) > ## maybe str(GeneEx) ; plot(GeneEx) ... > > > > cleanEx() > nameEx("JBCI") > ### * JBCI > > flush(stderr()); flush(stdout()) > > ### Name: JBCI > ### Title: The Joint Bertin Classification Index > ### Aliases: JBCI > > ### ** Examples > > ## Not run: > ##D A <- optile( arsim(144*5*20,c(12,12),6,0.1) , iter = 1000) > ##D > ##D p1 <- 0.1 + runif(5) > ##D p1 <- p1/sum(p1) > ##D > ##D A2 <- apply(A,1:2,function(z) rmultinom(1,z,p1)) > ##D A2 <- optile(A2, iter = 1000,return.type="table") > ##D > ##D BCI(A) > ##D BCI(A2) > ##D > ##D DA2 <- subtable(A2,1:3) > ##D names(DA2) <- c("X","Y","Z","Freq") > ##D > ##D rmb(~Y+Z+X,data=DA2) > ##D > ##D JBCI(A2,3) > ## End(Not run) > > > > cleanEx() > nameEx("ME") > ### * ME > > flush(stderr()); flush(stdout()) > > ### Name: ME > ### Title: Measure of Effectiveness > ### Aliases: ME > > ### ** Examples > > a <- arsim(2000,c(8,9,10),3,0.2) > ME(a) [1] 52435 > a2<-optME(a) > ME(a2) [1] 83260 > > > > cleanEx() > nameEx("MJnew") > ### * MJnew > > flush(stderr()); flush(stdout()) > > ### Name: MJnew > ### Title: Example Matrix Data > ### Aliases: MJnew > ### Keywords: datasets > > ### ** Examples > > data(MJnew) > ## maybe str(MJnew) ; plot(MJnew) ... > > > > cleanEx() > nameEx("USR") > ### * USR > > flush(stderr()); flush(stdout()) > > ### Name: USR > ### Title: MovieLens USER data > ### Aliases: USR > ### Keywords: datasets > > ### ** Examples > > data(USR) > ## maybe str(USR) ; plot(USR) ... > > > > cleanEx() > nameEx("agaricus") > ### * agaricus > > flush(stderr()); flush(stdout()) > > ### Name: agaricus > ### Title: Mushrooms > ### Aliases: agaricus > ### Keywords: datasets > > ### ** Examples > > data(agaricus) > ## maybe str(agaricus) ; plot(agaricus) ... > > > > cleanEx() > nameEx("ahist") > ### * ahist > > flush(stderr()); flush(stdout()) > > ### Name: ahist > ### Title: Histogram using active bins > ### Aliases: ahist > > ### ** Examples > > ahist(rnorm(100)) Warning: `geom_bar()` no longer has a `binwidth` parameter. Please use `geom_histogram()` instead. > ahist(rnorm(1000)) Warning: `geom_bar()` no longer has a `binwidth` parameter. Please use `geom_histogram()` instead. > ahist(rnorm(10000)) Warning: `geom_bar()` no longer has a `binwidth` parameter. Please use `geom_histogram()` instead. > > > ahist(rexp(100)) Warning: `geom_bar()` no longer has a `binwidth` parameter. Please use `geom_histogram()` instead. > ahist(rexp(1000)) Warning: `geom_bar()` no longer has a `binwidth` parameter. Please use `geom_histogram()` instead. > ahist(rexp(10000)) Warning: `geom_bar()` no longer has a `binwidth` parameter. Please use `geom_histogram()` instead. > > > ## Not run: > ##D ahist(rcauchy(1000)) > ##D ahist(rcauchy(1000), ival = 0.95) > ##D > ##D x <- c(rnorm(400),rnorm(200, mean=6)) > ##D ahist(x) > ##D > ##D x <- c(rnorm(400),rnorm(200, mean=16)) > ##D ahist(x) > ##D > ##D > ##D x <- c(rnorm(400),rnorm(200, mean=32)) > ##D ahist(x) > ## End(Not run) > > > > cleanEx() > nameEx("approx.dcor") > ### * approx.dcor > > flush(stderr()); flush(stdout()) > > ### Name: approx.dcor > ### Title: Distance Correlation Approximation > ### Aliases: approx.dcor > > ### ** Examples > > ## Not run: > ##D > ##D # The straightforward way of approximating the distance correlation fails: > ##D # for instance the computation of dcor for a random sample with 4000 observations > ##D # takes pretty long but drawing samples of 500, 1000 or even 2000 observations > ##D # leads to relatively big errors. > ##D # The approximation via approx.dcor is very fast and for > ##D # n = 50 or n=100 the results are very close to the truth > ##D > ##D require(energy) > ##D x<- rnorm(4000,mean=10,sd=3) > ##D y <- rnorm(1,sd=0.01)*(x-10)^3 + rnorm(1,sd=0.1)*(x-10)^2 > ##D + rnorm(1)*(x-10)+rnorm(4000,sd=4) > ##D > ##D system.time(dd <- dcor(x,y)) > ##D system.time(dd0 <- wdcor(x,y))[[3]] > ##D dd - dd0 > ##D > ##D > ##D system.time(da100 <- approx.dcor(x,y,100))[[3]] > ##D da100-dd0 > ##D > ##D # For a smaller sample size we can try out how good the approximation really is: > ##D test<-replicate(100,{ > ##D N <- 1000 > ##D x<- rnorm(N,mean=10,sd=3) > ##D y <- rnorm(1,sd=0.01)*(x-10)^3 + rnorm(1,sd=0.1)*(x-10)^2 > ##D y <- y + rnorm(1)*(x-10)+rnorm(N,sd=4) > ##D > ##D dd <- wdcor(x,y) > ##D dd25 <- approx.dcor(x,y,25) > ##D dd50 <- approx.dcor(x,y,50) > ##D dd100 <- approx.dcor(x,y,100) > ##D dd75 <- approx.dcor(x,y,75) > ##D > ##D dd25c <- approx.dcor(x,y,25,correct = TRUE) > ##D dd50c <- approx.dcor(x,y,50,correct = TRUE) > ##D dd100c <- approx.dcor(x,y,100,correct = TRUE) > ##D dd75c <- approx.dcor(x,y,75,correct = TRUE) > ##D c(2*dd, dd25, dd50, dd75, dd100, dd25c, dd50c, dd75c, dd100c)-dd > ##D }) > ##D > ##D rm<-apply(test,1,mean) > ##D > ##D plot( seq(25,100,25), rm[2:5],type="l", > ##D ylim= c(min(rm),abs(min(rm))), xlab = "No. of bins per axis",ylab = "error") > ##D points( seq(25,100,25), rm[2:5],pch=19) > ##D points( seq(25,100,25), rm[6:9],type="l", col=2) > ##D points( seq(25,100,25), rm[6:9],pch=19,col=2) > ##D abline(h=0,lwd=3) > ##D legend( 25,abs(min(rm)),legend=c("raw value after binning","corrected value"), > ##D col=1:2,lwd=3) > ## End(Not run) > > > > cleanEx() > nameEx("arsim") > ### * arsim > > flush(stderr()); flush(stdout()) > > ### Name: arsim > ### Title: block-structured arrays > ### Aliases: arsim > > ### ** Examples > > A <- arsim(1000, c(12,12), 3, shuffle = FALSE) > fluctile(A) viewport[base] > > A <- arsim(1000, c(12,12), 3, shuffle = FALSE, dimnames = list(NULL,letters)) > dimnames(A) [[1]] [1] "a" "b" "c" "d" "e" "f" "g" "h" "i" "j" "k" "l" [[2]] [1] "a" "b" "c" "d" "e" "f" "g" "h" "i" "j" "k" "l" > > A <- arsim(4000, c(11,7,5), 3, shuffle = TRUE, dimnames = list(0:2,letters)) > dimnames(A) [[1]] [1] "0e" "0g" "0d" "0f" "0i" "0k" "0b" "0j" "0a" "0h" "0c" [[2]] [1] "1g" "1d" "1e" "1f" "1b" "1c" "1a" [[3]] [1] "2a" "2e" "2d" "2c" "2b" > > ## Not run: > ##D A2<- arsim(1000, c(12,12,12), 3, shuffle = FALSE) > ##D fluctile3d(A2, shape ="oct") > ## End(Not run) > > > > > cleanEx() > nameEx("barysort") > ### * barysort > > flush(stderr()); flush(stdout()) > > ### Name: barysort > ### Title: row and column moment reordering > ### Aliases: barysort > > ### ** Examples > > # a good and quick solution: > a <- arsim(2000,c(24,24),6, noise=0.4) > fluctile(a2<-barysort(a)) viewport[base] > BCI(a2) [1] 0.3262786 > > # which is near > a3 <- optile(a, iter=100) > BCI(a3) [1] 0.3194291 > > > ## Not run: > ##D a <- arsim(64000,c(256,256),16, noise=0.4) > ##D s1 <- system.time( bci1 <- BCI(a1<-optile(a, fun = "barysort", > ##D foreign=".Call", iter = 1)) )[[3]] > ##D > ##D s2 <- system.time( bci2 <- BCI(a2<-optile(a, iter=1)) )[[3]] > ##D s3 <- system.time( bci3 <- BCI(a3<-optile(a, fun="IBCC",iter=1)) )[[3]] > ## End(Not run) > > > > > cleanEx() > nameEx("carcustomers") > ### * carcustomers > > flush(stderr()); flush(stdout()) > > ### Name: carcustomers > ### Title: The car customers dataset from 1983 > ### Aliases: carcustomers > ### Keywords: datasets > > ### ** Examples > > data(Autos) Warning in data(Autos) : data set ‘Autos’ not found > ## maybe str(Autos) ; plot(Autos) ... > > > > cleanEx() > nameEx("cfcl") > ### * cfcl > > flush(stderr()); flush(stdout()) > > ### Name: cfcl > ### Title: Extract clusters from cfluctile > ### Aliases: cfcl > > ### ** Examples > > a <- arsim(2000, c(12,17),5, noise=0.2,shuffle = FALSE) > cfa <- cfluctile(a) > > da <- as.data.frame(a) > clusters <- cfcl( da, ll = cfa) > > dev.new() > fluctile(xtabs(da$Freq~clusters[,1] + clusters[,2])) viewport[base] > > table(combcl(clusters)) 1 2 3 4 5 0 2 18 15 8 2 159 > > > > cleanEx() > nameEx("cfluctile") > ### * cfluctile > > flush(stderr()); flush(stdout()) > > ### Name: cfluctile > ### Title: Pseudo-Diagonal Partitioning for two-way tables > ### Aliases: cfluctile > > ### ** Examples > > > M <- arsim(10000,c(30,40),8, noise = 0.4) > cfluctile( M2 <- optile(M,iter=20) ) > > cfluctile( M3 <- sortandcut(M) ) > > cfluctile( M3, nsplit = 4 ) > > cfluctile( M3, maxsplit = 12 ) > > cfluctile( M3, tau0 = 0.8 ) > > > > > > cleanEx() > nameEx("cmat") > ### * cmat > > flush(stderr()); flush(stdout()) > > ### Name: cmat > ### Title: pairwise association matrix > ### Aliases: cmat > > ### ** Examples > > ## Not run: > ##D m1 <- cmat(olives) > ##D fluctile(1 - m1,shape="o") > ## End(Not run) > > > > cleanEx() > nameEx("cohen") > ### * cohen > > flush(stderr()); flush(stdout()) > > ### Name: cohen > ### Title: Cohens Kappa for rectangular matrices > ### Aliases: cohen > > ### ** Examples > > a <- arsim(2000,c(12,12),6) > cohen(a) [1] 0.06774493 > cohen(optile(a)) [1] 0.6467025 > > > > cleanEx() > nameEx("combcl") > ### * combcl > > flush(stderr()); flush(stdout()) > > ### Name: combcl > ### Title: Combine categorical variables from cfluctile and cflcl > ### Aliases: combcl > > ### ** Examples > > > a <- arsim(2000, c(12,17),5, noise=0.2,shuffle = FALSE) > cfa <- cfluctile(a) > > da <- as.data.frame(a) > clusters <- cfcl( da, ll = cfa) > > dev.new() dev.new(): using pdf(file="Rplots1.pdf") > fluctile(xtabs(da$Freq~clusters[,1] + clusters[,2])) viewport[base] > > table(combcl(clusters)) 1 2 3 4 5 0 2 18 15 8 2 159 > > > > > cleanEx() > nameEx("cutbw") > ### * cutbw > > flush(stderr()); flush(stdout()) > > ### Name: cutbw > ### Title: Active binning > ### Aliases: cutbw > > ### ** Examples > > y<-cutbw(c(rnorm(200),rnorm(100,mean=8)),k = 30, min_n = 1) > barplot(table(y)) > > > > cleanEx() > nameEx("dcor") > ### * dcor > > flush(stderr()); flush(stdout()) > > ### Name: wdcor > ### Title: Weighted Distance Correlation > ### Aliases: wdcor wdcor.table wdcor.default wdcor.data.frame > > ### ** Examples > > > # repeat and change N for different results and computation times. > N <- 2000 > x1 <- rnorm(N,mean=10,sd=3) > x2 <- runif(N,0,40) > x3 <- rnorm(N,mean=30,sd=4) > x <- sample(c(x1,x2,x3),N) > > y <- rnorm(1,sd=0.0001)*(x-mean(x))^4+ rnorm(1,sd=0.01)*(x-mean(x))^3 > y <- y+ rnorm(1,sd=0.1)*(x-mean(x))^2 > y <- y+ rnorm(1)*(x-mean(x))+rnorm(N,sd=runif(N,3,10)) > y <- y+ runif(N,0,20)*sin(abs(scale(x))*2*pi) > > require(scales) Loading required package: scales > plot(x,y,pch=19,col=alpha("black",0.2)) > system.time(dd<-wdcor(x,y)) user system elapsed 0.686 0.050 0.740 > > y2 <- runif(2000) > system.time(dde<-wdcor(x,y2)) user system elapsed 0.688 0.049 0.742 > dd [1] 0.4050083 > dde [1] 0.02132741 > > ## Not run: > ##D y <- diamonds$price > ##D x <- diamonds$carat > ##D > ##D length(x) # 53940 > ##D > ##D # auto approximation via approx.dcor > ##D wdcor(x,y) > ##D > ##D # the weighted distance correlation is also applicable to > ##D # discrete data: > ##D > ##D A <- arsim(2000,c(12,12),4,0.1) > ##D wdcor(A) > ##D wdcor(optile(A)) > ##D wdcor(optile(A, fun = "distcor")) > ##D > ##D > ##D # kernel density weights: > ##D kd <- kde2d(x,y,n=50) > ##D > ##D xy <- expand.grid(kd$x,kd$y) > ##D wdcor(xy[,1],xy[,2], w = kd$z) > ##D # this is the approximate distance correlation for the 2D density estimate > ## End(Not run) > > # a pairwise matrix: > D <- wdcor(olives[,3:10]) > fluctile(D^2, shape="c") viewport[base] > > > > > cleanEx() detaching ‘package:scales’ > nameEx("dcorMVdata") > ### * dcorMVdata > > flush(stderr()); flush(stdout()) > > ### Name: dcorMVdata > ### Title: Multivariate Distance Correlation for two sets of variables > ### Aliases: dcorMVdata > > ### ** Examples > > ## Not run: > ##D so <- scale(olives[,3:8]) > ##D dcorMVdata(so,ind=1) > ##D > ##D p1 <- princomp(so) > ##D so1 <- cbind(so,p1$scores[,1]) > ##D so2 <- cbind(so,p1$scores[,2]) > ##D so12 <- cbind(so,p1$scores[,1:2]) > ##D > ##D dcorMVdata(so1,ind=7) > ##D dcorMVdata(so2,ind=7) > ##D dcorMVdata(so12,ind=7:8) > ##D # how about principal curves? > ## End(Not run) > > > > cleanEx() > nameEx("dcorMVtable") > ### * dcorMVtable > > flush(stderr()); flush(stdout()) > > ### Name: dcorMVtable > ### Title: Multivariate Distance Correlation for two sets of variables > ### Aliases: dcorMVtable > > ### ** Examples > > ## Not run: > ##D A2 <- arsim(2000,c(8,9),5,0.1) > ##D A2 <- optile(A2, iter=100) > ##D BCI(A2) > ##D wdcor(A2) > ##D > ##D p1 <- runif(11)+0.1 > ##D p1 <- p1/sum(p1) > ##D A2b <- apply(A2,1:2,function(z) rmultinom(1,z,p1)) > ##D > ##D # now the first variable is roughly independent from the other two: > ##D > ##D dcorMVtable(as.table(A2b),ind = 1) > ##D > ##D # here the third variable is NOT independent from the others: > ##D A3 <- arsim(2000,c(8,9,11),5,0.1) > ##D A3 <- optile(A3, iter=100) > ##D BCI(A3) > ##D dcorMVtable(A3,ind = 3) > ##D > ##D > ## End(Not run) > > > > cleanEx() > nameEx("dendro") > ### * dendro > > flush(stderr()); flush(stdout()) > > ### Name: dendro > ### Title: Waterfall Dendrogram > ### Aliases: dendro > > ### ** Examples > > ## Not run: > ##D library(amap) > ##D hc <- hcluster(USArrests) > ##D # the full plot: > ##D dendro(hc, k = 24, min.gap = 0.00) > ##D > ##D # aggregation splits within 0.02 maximum height > ##D dendro(hc, k = 24, min.gap = 0.02) > ##D > ##D # the same graphic with spline curves instead of straight lines. > ##D dendro(hc, k = 24, min.gap = 0.02, spline = TRUE) > ##D > ##D # olive oil data > ##D sx <- scale(olives[,-c(1,2,11)]) > ##D hc <- hcluster(sx) > ##D plot(hc) > ##D dendro(hc, 120, color.id = 6, min.gap=0.005) > ##D dendro(hc, 120, color.id = 6, min.gap=0.1) > ##D > ##D dendro(hc, 120, color.id = 6, min.gap=0.1, spline = TRUE) > ## End(Not run) > > > > cleanEx() > nameEx("dmc") > ### * dmc > > flush(stderr()); flush(stdout()) > > ### Name: dmc > ### Title: dmc 2009 insurance variables > ### Aliases: dmc > ### Keywords: datasets > > ### ** Examples > > data(dmc) > > > > cleanEx() > nameEx("eco") > ### * eco > > flush(stderr()); flush(stdout()) > > ### Name: eco > ### Title: ADAC Eco test data > ### Aliases: eco > ### Keywords: datasets > > ### ** Examples > > data(eco2plus) Warning in data(eco2plus) : data set ‘eco2plus’ not found > ## maybe str(eco2plus) ; plot(eco2plus) ... > > > > cleanEx() > nameEx("facetshade") > ### * facetshade > > flush(stderr()); flush(stdout()) > > ### Name: facetshade > ### Title: facetshade > ### Aliases: facetshade > > ### ** Examples > > > # produces a modified data.frame mdata and returns: > # ggplot(data = mdata, mapping, ... ) + facet_grid(f) > > require(scales) Loading required package: scales > require(ggplot2) Loading required package: ggplot2 > > # facetshade object: > fs1 <- facetshade( data = olives, aes(x = palmitoleic, y = oleic), + f = .~Region ) > > # only the background-data > fs1 + geom_point( colour = alpha(1, 0.2) ) > > # the actual data added in a second layer: > fs1 + geom_point( colour = alpha(1, 0.2) ) + + geom_point( data = olives ) > > # now again with colours: > fs1 + geom_point( colour = alpha(1, 0.2) ) + + geom_point( data = olives, aes(colour = Area) ) > > # a different geom for the background-plot: > fs1 + geom_density2d(colour=alpha(1,0.1)) + + geom_point( data = olives, aes(colour = Area) ) > ## Not run: > ##D # OPTION 2: specify geom in facetshade call: > ##D fs1b <- facetshade( data = olives, aes(x = palmitoleic, y = oleic), > ##D f = .~Region , geom = geom_point) > ##D fs1b + geom_point(aes(colour = Area)) > ## End(Not run) > > > # compare with complement: > fs2 <- facetshade( data = olives, aes(x = palmitoleic, y = oleic), + f = .~Region , bg.all = FALSE) > > fs2 + geom_density2d(colour=alpha(1,0.1)) + + geom_point( data = olives, aes(colour = Area) ) > ## Not run: > ##D # OPTION 2: specify geom in facetshade call: > ##D fs2b <- facetshade( data = olives, aes(x = palmitoleic, y = oleic), > ##D f = .~Region , geom = geom_density2d, bg.all = FALSE) > ##D fs2b + geom_point(aes(colour = Area)) > ## End(Not run) > > > # a second dataset: > ## Not run: > ##D data(EURO4PlayerSkillsSep11, package="SportsAnalytics") > ##D e4 <- subset(EURO4PlayerSkillsSep11,Attack > 0 & Defence > 0) > ##D > ##D > ##D fs3 <- facetshade( data = e4, aes(x = Attack, y = Defence), > ##D f = .~Position , compare.all = TRUE) > ##D > ##D fs3 + geom_point( colour = alpha(1, 0.1) ) + > ##D geom_point( data = e4, aes(colour = Position) ,alpha=0.3) > ##D > ##D fs3 + geom_bin2d( colour = alpha(1, 0.1) ) + > ##D geom_point( data = e4, aes(colour = Position) ,alpha=0.3) > ##D > ##D # now with two facet variables > ##D fs4 <- facetshade( data = e4, aes(x = Attack, y = Defence), > ##D f = Position~Side , compare.all = TRUE) > ##D > ##D fs4 + geom_point( colour = alpha(1, 0.1) ) + > ##D geom_point( data = e4, aes(colour = Position)) > ## End(Not run) > > ## Not run: > ##D library(FinCal) > ##D sh13 <- get.ohlcs.google(symbols=c("AAPL","GOOG","IBM", "MSFT"), > ##D start="2013-01-01",end="2013-12-31") > ##D > ##D # OPTION 1 ------------ > ##D require(reshape2) > ##D SH13 <- data.frame(date = as.Date(sh13$AAPL$date), > ##D sapply(sh13,"[" ,"close",USE.NAMES=TRUE)) > ##D > ##D names(SH13) <- c("date",names(sh13)) > ##D SH13[,-1] <- apply(SH13[,-1], 2, function(x) 100*x/x[1]) > ##D SH13am <- melt(SH13, id="date") > ##D > ##D > ##D # OPTION 2 ------------ > ##D #SH13am <- do.call(rbind, > ##D # mapply(function(z,y){ > ##D # data.frame( > ##D # date = as.Date(z$date), > ##D # value = 100*z$close/z$close[1], > ##D # variable = y) > ##D # } , z = sh13, y = names(sh13), SIMPLIFY = FALSE)) > ##D # --------------------- > ##D > ##D > ##D # original plot from GDAR: > ##D ggplot(SH13am, aes(date, y=value, colour=variable,group=variable)) + > ##D geom_line()+ xlab("") + ylab("") + > ##D theme(legend.position="bottom") + > ##D theme(legend.title=element_blank()) > ##D > ##D > ##D # facetshade: > ##D # compare to "average" of others: > ##D facetshade(SH13am,aes(x=date, y=value),f = .~variable, bg.all = FALSE) + > ##D geom_smooth(aes(x=date, y=value),method="loess",span = 1/28) + > ##D geom_line(data=SH13am,aes(colour=variable),show_guide=FALSE) + > ##D xlab("") + ylab("") > ##D > ##D # compare to all others > ##D facetshade(SH13am,aes(x=date, y=value), > ##D f = .~variable, bg.all = FALSE,keep.orig = TRUE) + > ##D geom_line(aes(x=date, y=value,group=orig.variable),colour = alpha(1,0.3)) + > ##D geom_line(data=SH13am,aes(colour=variable),show_guide=FALSE, size = 1.2) + > ##D xlab("") + ylab("") > ##D > ##D # --- parallel coordinates --- # > ##D > ##D sc <- scale(olives[,3:10]) > ##D > ##D # OPT: order by var > ##D ord <- order(apply(sc,2,sd)) > ##D sc <- sc[,ord] > ##D > ##D require(scales) > ##D # OPT: align at median > ##D sc <- apply(sc,2,function(z) rescale_mid(z, mid = median(z,na.rm=TRUE))) > ##D > ##D > ##D > ##D require(reshape2) > ##D require(ggplot2) > ##D > ##D msc <- melt(sc) > ##D msc$Area <- olives$Area > ##D > ##D > ##D f1 <- facetshade(msc,aes(x=Var2,y=value,group=Var1),f=.~Area, bg.all = FALSE) > ##D f1+geom_line(alpha=0.05)+ > ##D geom_line(data=msc,aes(colour=Area),alpha=0.2)+ > ##D facet_wrap(f=~Area,nrow=3) > ##D > ## End(Not run) > ## Not run: > ##D # TESTCODE: instead of creating a new object > ##D # a shade layer is added to an existing ggplot > ##D # NOTE: function CHANGES the object! > ##D > ##D # highlighting + alpha > ##D pp0 <- ggplot()+geom_point(data = olives, > ##D aes(x = palmitoleic, y = palmitic), colour = 2) + facet_wrap(~Area, ncol = 3) > ##D extracat:::facetshade2(pp0, alpha = 0.1, colour = 1) > ##D > ##D # colours for both, alpha for shade > ##D pp1 <- ggplot()+geom_point(data = olives, > ##D aes(x = palmitoleic, y = oleic, colour = Area)) + facet_grid(.~Region) > ##D extracat:::facetshade2(pp1, alpha = 0.1) > ##D > ##D # different geom and colour for shade > ##D pp2 <- ggplot()+geom_point(data = olives, > ##D aes(x = palmitoleic, y = oleic, colour = Area)) + facet_grid(.~Region) > ##D extracat:::facetshade2(pp2, geom = geom_density2d, > ##D mapping = aes(colour = NULL), colour = 7) > ##D > ##D # smooth over points shade with matching colours > ##D pp3 <- ggplot()+geom_smooth(data = olives, > ##D aes(x = palmitoleic, y = oleic, colour = Region)) + facet_grid(.~Region) > ##D extracat:::facetshade2(pp3, geom = geom_point, > ##D mapping = aes(colour = orig.Region), keep.orig = TRUE) > ##D > ## End(Not run) > > > > > > > cleanEx() detaching ‘package:ggplot2’, ‘package:scales’ > nameEx("fluctile") > ### * fluctile > > flush(stderr()); flush(stdout()) > > ### Name: fluctile > ### Title: fluctuation diagrams > ### Aliases: fluctile > > ### ** Examples > > M <- arsim(1000, c(12,12), 3) > fluctile(M) viewport[base] > > M2 <- optile(M) > > # the standard fluctuation diagram with centralized rectangles > fluctile(M2) viewport[base] > > # the standard fluctuation diagram with centralized octagons > fluctile(M2, shape = "o") viewport[base] > > #another option such as it is used in iplots or MONDRIAN > # is to plot the rectangles in the bottom left corner > fluctile(M2, just ="lb") viewport[base] > > # a multiple barchart > fluctile(M2, just ="b", dir = "h") viewport[base] > > # or with vertical bars > fluctile(M2, just ="l", dir = "v") viewport[base] > > # a same-binsize-plot > fluctile(M2, dir = "n") viewport[base] > > require(MASS) Loading required package: MASS > fluctile(xtabs(Freq~Type+Infl+Cont+Sat,data=housing),dir="h",just="b", + lab.opt=list(lab.cex=1)) > > A <- arsim(2000, c(6,6,4,4), 3, shuffle = FALSE, noise = 0.05) > fluctile(A) > > ## Not run: > ##D # airport footprints: Unique Carrier vs. Destination > ##D require(grid) > ##D iata <- c("ATL","BOS","CLT", "DEN" , "DFW", "DTW", > ##D "EWR", "IAH", "LAS", "LAX", "MCO", "MSP", "ORD", "PHX", "SFO", "SLC") > ##D > ##D > ##D mat.layout <- grid.layout(nrow = 4 , ncol = 4 , widths = 1/4, heights=1/4) > ##D grid.newpage() > ##D vp.mat <- viewport(layout = mat.layout) > ##D pushViewport(vp.mat) > ##D > ##D for(i in seq_along(iata)){ > ##D > ##D ap <- assign(iata[i],read.table( > ##D paste("http://rosuda.org/lehre/SS09-f/datasets/air07s_", > ##D iata[i],".txt",sep=""),sep="\t",quote="",header=T) ) > ##D > ##D tt <- with(ap, table(UniqueCarrier,Dest)) > ##D > ##D jj <- ceiling(i/4) > ##D ii <- i - (jj-1)*4 > ##D > ##D fluctile(optile(tt,iter=100),vp=c(ii,jj), > ##D lab.opt=list(rot=0,lab.cex=0.5), > ##D border=c(0.1,0.02,0.02,0.15),gap.prop=0.2) > ##D > ##D pushViewport(viewport(layout.pos.row = ii, layout.pos.col = jj)) > ##D grid.text(iata[i],0.5,0.8,gp=gpar(col=2)) > ##D popViewport() > ##D } > ##D > ##D popViewport() > ##D rm(ap) > ##D > ## End(Not run) > > > > > > cleanEx() detaching ‘package:MASS’ > nameEx("getbw") > ### * getbw > > flush(stderr()); flush(stdout()) > > ### Name: getbw > ### Title: Active binning > ### Aliases: getbw > > ### ** Examples > > > require(scales) Loading required package: scales > > hist(x <- rexp(200,1/10),breaks=gb<-getbw(x,24,min_n = 5, warn=TRUE), + col = alpha(attr(gb,"outlier")+1,0.3)) [1] 0.6 The number of observations is smaller than k*min_n. Reducing min_n to 3> > hist(x <- rexp(2000,1/10),breaks=gb<-getbw(x,24,min_n = 5,warn=TRUE), + col = alpha(attr(gb,"outlier")+1,0.3)) > > > > x <- rlnorm(1000,log(10),log(4)) > x <- c(x, rnorm(500,400,30)) > > hist(x ,breaks=gb<-getbw(x,24,min_n = 5,warn=TRUE), + col = alpha(attr(gb,"outlier")+1,0.3)) > > > > x <- rlnorm(1000,log(10),log(4)) > x <- c(x, rnorm(500,800,30)) > > hist(x ,breaks=gb<-getbw(x,24,min_n = 5,warn=TRUE), + col = alpha(attr(gb,"outlier")+1,0.3)) > > ## Not run: > ##D > ##D bws1 <-replicate(1000,{ > ##D x <- rexp(200,1/10) > ##D gb <- getbw(x,20) > ##D attr(gb,"bw") > ##D > ##D }) > ##D hist(bws1,breaks=getbw(bws1,30)) > ##D > ##D > ##D > ##D bws2 <-replicate(1000,{ > ##D x <- rnorm(200) > ##D x <- x/rnorm(200) > ##D gb <- getbw(x,20) > ##D attr(gb,"bw") > ##D > ##D }) > ##D hist(bws2,breaks=getbw(bws2,30)) > ##D > ##D > ##D mov <- read.table("http://www.rosuda.org/lehre/WS1213-f/MovieLens.txt", > ##D header=T, sep="\t") > ##D > ##D require(extracat) > ##D with(mov,plot(MovieVotes,meanMovieRat, > ##D pch=19,col=alpha("black",0.2))) > ##D with(mov, fluctile(table(cutbw(MovieVotes,30), > ##D cutbw(meanMovieRat,30)))) > ##D > ##D > ##D > ##D with(USR, fluctile(table(occupation,cutbw(meanUserRat,30)), > ##D dir="h",just="b")) > ##D > ##D with(USR, fluctile(log(1+table(cutbw(Pct.Animation,50), > ##D cutbw(Pct.Children.s,50))))) > ##D > ##D with(USR, barplot(table(cutbw(Pct.Animation,50,min_n=5)))) > ##D > ## End(Not run) > > > > > > > cleanEx() detaching ‘package:scales’ > nameEx("getcolors") > ### * getcolors > > flush(stderr()); flush(stdout()) > > ### Name: getcolors > ### Title: Create a color vector > ### Aliases: getcolors > > ### ** Examples > > ## Not run: > ##D require(MASS) > ##D mat.layout <- grid.layout(nrow = 2 , ncol = 2) > ##D vp.mat <- viewport(layout = mat.layout) > ##D pushViewport(vp.mat) > ##D rmb(formula = ~Type+Infl+Cont+Sat, data = housing, col = "rgb", vp = c(1,1)) > ##D rmb(formula = ~Type+Infl+Cont+Sat, data = housing, col = "q17", vp = c(1,2)) > ##D rmb(formula = ~Type+Infl+Cont+Sat, data = housing, col = "hcl", vp = c(2,1)) > ##D rmb(formula = ~Type+Infl+Cont+Sat, data = housing, col = "seq", vp = c(2,2)) > ##D popViewport() > ## End(Not run) > > > > cleanEx() > nameEx("getpath") > ### * getpath > > flush(stderr()); flush(stdout()) > > ### Name: getpath > ### Title: Path extracation from quickfechner objects > ### Aliases: getpath > > ### ** Examples > > #not a distance matrix, but a similarity matrix in some sense > cx <- 1-abs(cor(olives[-c(1,2,11)])) > > cx2 <- quickfechner(cx) > getpath(cx2,from=1,to=5) [1] 1 4 5 > > > > > cleanEx() > nameEx("heattile") > ### * heattile > > flush(stderr()); flush(stdout()) > > ### Name: heattile > ### Title: Heatmap with Biclusters > ### Aliases: heattile > > ### ** Examples > > > > > > > ## Not run: > ##D > ##D ss <- sample(1:nrow(plants), 500) > ##D M <- t(as.matrix(plants[ ss, -1])) > ##D M <- optME(M) > ##D heattile(M, hm.palette = "seq") > ##D > ##D require(biclust) > ##D > ##D GE <- t(na.omit(GeneEx[,3:52])) > ##D > ##D # draw a sample of 1000 genes > ##D ss <- sample(1:ncol(GE),1000) > ##D > ##D EY <- GE[,ss] > ##D SEY <- scale(EY) > ##D > ##D # compute sensible initial row and column orders: > ##D require(seriation) > ##D s1 <- seriate(dist(SEY),method="GW") > ##D s2 <- seriate(dist(t(SEY)),method="GW") > ##D > ##D o1 <- get_order(s1,1) > ##D o2 <- get_order(s2,1) > ##D > ##D SEY <- SEY[o1,o2] > ##D > ##D # A plaid model with row effects > ##D b1 <- biclust(SEY,method=BCPlaid(),row.release=0.4, > ##D col.release=0.4, fit.model = y ~ m + a ) > ##D > ##D # index sets from b1 > ##D Is2 <- getIs(b1,dim(SEY), nstart = 1) > ##D > ##D # clusters in seriated matirx: > ##D heattile(SEY,biclust=b1,clust.palette="hsv",hm.palette="div", > ##D label = TRUE, border = c(0.1,0.01,0.03,0.03)) > ##D > ##D #clusters in optimized matrix > ##D heattile(SEY,Is=Is2,clust.palette="hsv",hm.palette="div", > ##D label = TRUE, border = c(0.1,0.01,0.03,0.03)) > ## End(Not run) > > > > > > cleanEx() > nameEx("hexpie") > ### * hexpie > > flush(stderr()); flush(stdout()) > > ### Name: hexpie > ### Title: Hexagonal Binning and Piecharts > ### Aliases: hexpie > > ### ** Examples > > data(olives) > x <- olives$oleic > y <- olives$linoleic > z <- olives$Region > > # the default > hexpie(x,y,z) > > ## Not run: > ##D # zooming in (transformation of the total number of obs in each bin) > ##D hexpie(x,y,z, freq.trans=sqrt) > ##D > ##D # circular shapes > ##D hexpie(x,y,z, freq.trans=sqrt, shape="pie") > ##D > ##D # classical piecharts > ##D hexpie(x,y,z, freq.trans=sqrt, shape="pie", p.rule ="angles") > ##D > ##D # the total numbers of obs are reflected via alpha-blending, > ##D # the grid is not shown and RGB colors are used > ##D hexpie(x,y,z, freq.trans=sqrt, shape="hex", p.rule ="radial", > ##D alpha.freq=TRUE, col ="rgb",show.hex=F) > ##D > ##D hexpie(x,y,z, freq.trans=NULL, shape="hex", p.rule ="radial", > ##D alpha.freq=TRUE, col ="rgb",show.hex=T) > ##D > ##D require(ggplot2) > ##D data(diamonds) > ##D x2 <- diamonds$carat > ##D y2 <- diamonds$price > ##D z2 <- diamonds$color > ##D > ##D # a standard plot with colors via ggplot2 > ##D qplot(x2,y2,colour=z2) > ##D > ##D # the hexpie version > ##D hexpie(x2,y2,z2,n=36) > ##D > ##D # due to the few bins with the majority of observations > ##D # it is sensible to zoom in > ##D hexpie(x2,y2,z2,n=36,freq.trans=function(s) log(1+s)) > ##D > ##D # the same, but this time the central color is the most frequent one > ##D hexpie(x2,y2,z2,n=36,freq.trans=function(s) log(1+s), decr.by.rank = TRUE) > ##D > ##D # this way the difference is more obvious > ##D # (although the color palette is better suited for ordinal target variables) > ##D > ##D mat.layout <- grid.layout(nrow = 1 , ncol = 2 , widths = c(1/2,1/2), heights=1) > ##D grid.newpage() > ##D vp.mat <- viewport(layout = mat.layout) > ##D pushViewport(vp.mat) > ##D > ##D vp1 <- viewport(layout.pos.row = 1, layout.pos.col = 1) > ##D pushViewport(vp1) > ##D > ##D hexpie(x2,y2,z2,n=18,freq.trans=NULL, > ##D decr.by.rank=NULL,col="div", vp = vp1) > ##D > ##D vp2 <- viewport(layout.pos.row = 1, layout.pos.col = 2) > ##D pushViewport(vp2) > ##D > ##D hexpie(x2,y2,z2,n=18,freq.trans=NULL, > ##D decr.by.rank=T,col="div", vp = vp1) > ##D popViewport() > ##D > ##D # random samples from the data (within bins) with many bins > ##D # (takes some time) > ##D require(scales) > ##D grid.newpage() > ##D hexpie(x2,y2,z2, freq.trans=function(s) log(1+s),random=1, > ##D n=240, show.hex=FALSE, col.opt=list(bg=alpha(1,0.7)),shape="c",col="rgb") > ## End(Not run) > > > > cleanEx() > nameEx("idat") > ### * idat > > flush(stderr()); flush(stdout()) > > ### Name: idat > ### Title: indicator dataframe > ### Aliases: idat > > ### ** Examples > > require(MASS) Loading required package: MASS > idat(housing) Sat:Low Sat:Medium Infl:Low Infl:Medium Type:Tower Type:Apartment 1 1 0 1 0 1 0 2 0 1 1 0 1 0 3 0 0 1 0 1 0 4 1 0 0 1 1 0 5 0 1 0 1 1 0 6 0 0 0 1 1 0 7 1 0 0 0 1 0 8 0 1 0 0 1 0 9 0 0 0 0 1 0 10 1 0 1 0 0 1 11 0 1 1 0 0 1 12 0 0 1 0 0 1 13 1 0 0 1 0 1 14 0 1 0 1 0 1 15 0 0 0 1 0 1 16 1 0 0 0 0 1 17 0 1 0 0 0 1 18 0 0 0 0 0 1 19 1 0 1 0 0 0 20 0 1 1 0 0 0 21 0 0 1 0 0 0 22 1 0 0 1 0 0 23 0 1 0 1 0 0 24 0 0 0 1 0 0 25 1 0 0 0 0 0 26 0 1 0 0 0 0 27 0 0 0 0 0 0 28 1 0 1 0 0 0 29 0 1 1 0 0 0 30 0 0 1 0 0 0 31 1 0 0 1 0 0 32 0 1 0 1 0 0 33 0 0 0 1 0 0 34 1 0 0 0 0 0 35 0 1 0 0 0 0 36 0 0 0 0 0 0 37 1 0 1 0 1 0 38 0 1 1 0 1 0 39 0 0 1 0 1 0 40 1 0 0 1 1 0 41 0 1 0 1 1 0 42 0 0 0 1 1 0 43 1 0 0 0 1 0 44 0 1 0 0 1 0 45 0 0 0 0 1 0 46 1 0 1 0 0 1 47 0 1 1 0 0 1 48 0 0 1 0 0 1 49 1 0 0 1 0 1 50 0 1 0 1 0 1 51 0 0 0 1 0 1 52 1 0 0 0 0 1 53 0 1 0 0 0 1 54 0 0 0 0 0 1 55 1 0 1 0 0 0 56 0 1 1 0 0 0 57 0 0 1 0 0 0 58 1 0 0 1 0 0 59 0 1 0 1 0 0 60 0 0 0 1 0 0 61 1 0 0 0 0 0 62 0 1 0 0 0 0 63 0 0 0 0 0 0 64 1 0 1 0 0 0 65 0 1 1 0 0 0 66 0 0 1 0 0 0 67 1 0 0 1 0 0 68 0 1 0 1 0 0 69 0 0 0 1 0 0 70 1 0 0 0 0 0 71 0 1 0 0 0 0 72 0 0 0 0 0 0 Type:Atrium Cont:Low Freq 1 0 1 21 2 0 1 21 3 0 1 28 4 0 1 34 5 0 1 22 6 0 1 36 7 0 1 10 8 0 1 11 9 0 1 36 10 0 1 61 11 0 1 23 12 0 1 17 13 0 1 43 14 0 1 35 15 0 1 40 16 0 1 26 17 0 1 18 18 0 1 54 19 1 1 13 20 1 1 9 21 1 1 10 22 1 1 8 23 1 1 8 24 1 1 12 25 1 1 6 26 1 1 7 27 1 1 9 28 0 1 18 29 0 1 6 30 0 1 7 31 0 1 15 32 0 1 13 33 0 1 13 34 0 1 7 35 0 1 5 36 0 1 11 37 0 0 14 38 0 0 19 39 0 0 37 40 0 0 17 41 0 0 23 42 0 0 40 43 0 0 3 44 0 0 5 45 0 0 23 46 0 0 78 47 0 0 46 48 0 0 43 49 0 0 48 50 0 0 45 51 0 0 86 52 0 0 15 53 0 0 25 54 0 0 62 55 1 0 20 56 1 0 23 57 1 0 20 58 1 0 10 59 1 0 22 60 1 0 24 61 1 0 7 62 1 0 10 63 1 0 21 64 0 0 57 65 0 0 23 66 0 0 13 67 0 0 31 68 0 0 21 69 0 0 13 70 0 0 5 71 0 0 6 72 0 0 13 > > > > cleanEx() detaching ‘package:MASS’ > nameEx("ihcrit") > ### * ihcrit > > flush(stderr()); flush(stdout()) > > ### Name: WBCI > ### Title: The Weighted Bertin Classification Index > ### Aliases: WBCI > > ### ** Examples > > M <-arsim(1000, c(12,12), 3) > BCI(M) [1] 0.8135658 > WBCI(M) [1] 1.035944 > > > M2 <- optile(M, iter = 100) > BCI(M2) [1] 0.2216375 > WBCI(M2) [1] 0.1864727 > > M3 <- optile(M, fun = "WBCC", iter = 100) > BCI(M3) [1] 0.2283537 > WBCI(M3) [1] 0.1628213 > > > > cleanEx() > nameEx("imat") > ### * imat > > flush(stderr()); flush(stdout()) > > ### Name: imat > ### Title: indicator variables > ### Aliases: imat > > ### ** Examples > > require(MASS) Loading required package: MASS > imat(housing$Type) Tower Apartment Atrium Terrace [1,] 1 0 0 0 [2,] 1 0 0 0 [3,] 1 0 0 0 [4,] 1 0 0 0 [5,] 1 0 0 0 [6,] 1 0 0 0 [7,] 1 0 0 0 [8,] 1 0 0 0 [9,] 1 0 0 0 [10,] 0 1 0 0 [11,] 0 1 0 0 [12,] 0 1 0 0 [13,] 0 1 0 0 [14,] 0 1 0 0 [15,] 0 1 0 0 [16,] 0 1 0 0 [17,] 0 1 0 0 [18,] 0 1 0 0 [19,] 0 0 1 0 [20,] 0 0 1 0 [21,] 0 0 1 0 [22,] 0 0 1 0 [23,] 0 0 1 0 [24,] 0 0 1 0 [25,] 0 0 1 0 [26,] 0 0 1 0 [27,] 0 0 1 0 [28,] 0 0 0 1 [29,] 0 0 0 1 [30,] 0 0 0 1 [31,] 0 0 0 1 [32,] 0 0 0 1 [33,] 0 0 0 1 [34,] 0 0 0 1 [35,] 0 0 0 1 [36,] 0 0 0 1 [37,] 1 0 0 0 [38,] 1 0 0 0 [39,] 1 0 0 0 [40,] 1 0 0 0 [41,] 1 0 0 0 [42,] 1 0 0 0 [43,] 1 0 0 0 [44,] 1 0 0 0 [45,] 1 0 0 0 [46,] 0 1 0 0 [47,] 0 1 0 0 [48,] 0 1 0 0 [49,] 0 1 0 0 [50,] 0 1 0 0 [51,] 0 1 0 0 [52,] 0 1 0 0 [53,] 0 1 0 0 [54,] 0 1 0 0 [55,] 0 0 1 0 [56,] 0 0 1 0 [57,] 0 0 1 0 [58,] 0 0 1 0 [59,] 0 0 1 0 [60,] 0 0 1 0 [61,] 0 0 1 0 [62,] 0 0 1 0 [63,] 0 0 1 0 [64,] 0 0 0 1 [65,] 0 0 0 1 [66,] 0 0 0 1 [67,] 0 0 0 1 [68,] 0 0 0 1 [69,] 0 0 0 1 [70,] 0 0 0 1 [71,] 0 0 0 1 [72,] 0 0 0 1 > > > > cleanEx() detaching ‘package:MASS’ > nameEx("innerval") > ### * innerval > > flush(stderr()); flush(stdout()) > > ### Name: innerval > ### Title: Interval boundaries > ### Aliases: innerval > > ### ** Examples > > x1 <- rnorm(200) > innerval(x1) [1] -1.914359 1.767287 > quantile(x1, c(0.025, 0.975)) 2.5% 97.5% -1.641215 2.075543 > > > x2 <- rexp(200) > innerval(x2, data.points = FALSE) [1] -1.636538 2.937560 > innerval(x2) [1] 0.001700975 2.919983244 > quantile(x2, c(0.025, 0.975)) 2.5% 97.5% 0.01158514 3.44677807 > > > > > cleanEx() > nameEx("itab") > ### * itab > > flush(stderr()); flush(stdout()) > > ### Name: itab > ### Title: Independence Table > ### Aliases: itab > > ### ** Examples > > A <- optile(arsim(4000,c(13,17),4,0.1),iter=10) > fluctile(A) viewport[base] > fluctile(itab(A)) viewport[base] > D <- A-itab(A) > G <- (D)^2/itab(A) > fluctile(G, tile.col = c(2,4)[1+ (D>0)]) viewport[base] > > > > > cleanEx() > nameEx("kendalls") > ### * kendalls > > flush(stderr()); flush(stdout()) > > ### Name: kendalls > ### Title: Kendalls Tau for a matrix > ### Aliases: kendalls > > ### ** Examples > > M <- arsim(300,c(8,8),3) > kendalls(M) [1] -0.2031935 > kendalls(optile(M)) [1] 0.7266354 > > > > cleanEx() > nameEx("olives") > ### * olives > > flush(stderr()); flush(stdout()) > > ### Name: olives > ### Title: olive oil fatty acids > ### Aliases: olives > ### Keywords: datasets > > ### ** Examples > > data(olives) > > > > cleanEx() > nameEx("optME") > ### * optME > > flush(stderr()); flush(stdout()) > > ### Name: optME > ### Title: Optimizing ME > ### Aliases: optME > > ### ** Examples > > a <- arsim(2000,c(8,9,10),3,0.2) > ME(a) [1] 52435 > a2<-optME(a) > ME(a2) [1] 83260 > > > > cleanEx() > nameEx("optile") > ### * optile > > flush(stderr()); flush(stdout()) > > ### Name: optile > ### Title: Reordering Categorical Data > ### Aliases: optile optile.list > > ### ** Examples > > > # simple simulated example > A <- arsim(2000, c(11,13),3,0.3) > > fluctile(A) viewport[base] > fluctile(optile(A)) viewport[base] > fluctile(optile(A, iter = 100)) viewport[base] > fluctile(optile(A, fun = "CA")) viewport[base] > fluctile(optile(A, fun = "barysort", foreign = ".Call")) viewport[base] > > # simulated mv example > A2 <- arsim(20000, c(6,7,8,9),3,0.1) > > scpcp(A2,sel="data[,1]") > > scpcp(A3 <- optile(A2,iter=20),sel="data[,1]") > > dev.new() dev.new(): using pdf(file="Rplots2.pdf") > fluctile(A3) > > ## Not run: > ##D ############ ------------ EXAMPLE I ------------ ############ > ##D # ----- Cluster results from the Current Population Survey ----- # > ##D data(CPScluster) > ##D cpsX = subtable(CPScluster,c(5, 26, 34, 38, 39), allfactor=TRUE) > ##D > ##D # joint and stepwise optimization of BCC > ##D ss <- optile(cpsX,presort=TRUE, return.data=TRUE, method="joint") > ##D ss2 <- optile(cpsX,presort=TRUE, return.data=TRUE, method="sw") > ##D > ##D # original cpcp plot > ##D cpcp(cpsX) > ##D > ##D # cpcp for joint algorithm > ##D cpcp(ss) > ##D > ##D # cpcp and fluctuation for the stepwise algorithm > ##D # (should be good for pcp plots and hierarchical plots) > ##D fluctile(xtabs(Freq~.,data=ss2[,-4])) > ##D cpcp(ss2) > ##D > ##D # The multivariate algorithm > ##D ss3 <- optile(cpsX,presort=TRUE, return.data=TRUE, method=NULL) > ##D cpcp(ss3) > ##D > ##D # cpcp for casort algorithm > ##D ssca <- optile(cpsX,presort=FALSE, fun = "casort", return.data=TRUE, method="joint") > ##D cpcp(ssca) > ##D > ##D # cpcp for rmca algorithm results. works better for the dmc data > ##D ssR <- optile(cpsX,presort=FALSE, fun = "rmca", return.data=TRUE, method=NULL) > ##D cpcp(ssR) > ##D > ##D > ##D # cpcp for csvd algorithm > ##D ssC <- optile(cpsX,presort=FALSE, fun = "csvd", return.data=TRUE, method=NULL) > ##D fluctile(xtabs(Freq~.,data=ssC[,-4])) > ##D cpcp(ssC) > ##D > ##D # cpcp for presort algorithm with 20 iterations > ##D ssP <- optile(cpsX,presort=FALSE, fun = "IBCC", > ##D return.data=TRUE, method=NULL, foreign = ".Call",iter=20) > ##D cpcp(ssP) > ##D > ##D ############ ------------ EXAMPLE II ------------ ############ > ##D # ------------------------------- Italian wines ------------------------------ # > ##D library(MMST) > ##D data(wine) > ##D > ##D swine <- scale(wine[,1:13]) > ##D kmd <- data.frame(wine$class, replicate(9, kmeans(swine, centers = 6)$cluster) ) > ##D kmd <- subtable(kmd, 1:10, allfactor = TRUE) > ##D > ##D cpcp(kmd) > ##D > ##D # there is a good joint order and hence the joint result is better than the stepwise > ##D kmd2 <- optile(kmd, method = "sw") > ##D kmd3 <- optile(kmd, method = "joint") > ##D > ##D cpcp(kmd2) > ##D cpcp(kmd3) > ##D > ##D > ##D > ##D ############ ------------ EXAMPLE III ------------ ############ > ##D # ---------------- The BicatYeast microarray dataset ---------------- # > ##D > ##D # ----- with different clusterings for the genes ----- # > ##D library(biclust) > ##D data(BicatYeast) > ##D > ##D Dby <- dist(BicatYeast) > ##D > ##D hc1 <- hclust(Dby, method = "ward") > ##D hc2 <- hclust(Dby, method = "average") > ##D hc3 <- hclust(Dby, method = "complete") > ##D > ##D hcc1 <- cutree(hc1, k = 6) > ##D hcc2 <- cutree(hc2, k = 6) > ##D hcc3 <- cutree(hc3, k = 6) > ##D > ##D km1 <- kmeans(BicatYeast, centers = 6, nstart = 100, iter.max = 30)$cluster > ##D > ##D library(mclust) > ##D mc1 <- Mclust(BicatYeast, G = 6)$class > ##D > ##D clusterings <- data.frame(hcc1,hcc2,hcc3,km1,mc1) > ##D clusterings <- subtable(clusterings, 1:5, allfactor = TRUE) > ##D > ##D clusterings2 <- optile(clusterings, method = "joint") > ##D clusterings3 <- optile(clusterings, fun = "casort") > ##D > ##D cpcp(clusterings2) > ##D > ##D # a fluctuation diagram of all but the avg. clustering > ##D fluctile(xtabs(Freq~.,data=clusterings2[,-2])) > ##D > ##D # compute agreement via Fleiss kappa in irr: > ##D require(irr) > ##D rawdata <- untableSet(clusterings2) > ##D for(i in 1:5) levels(rawdata[,i]) <- 1:6 > ##D (kappam.fleiss(rawdata)) > ##D (kappam.fleiss(rawdata[,-2])) > ##D > ##D > ##D ## Let's have a look at kmeans with 2:12 clusters > ##D library(biclust) > ##D data(BicatYeast) > ##D > ##D cs <- NULL > ##D for(i in 2:12) cs <- cbind(cs, kmeans(BicatYeast, centers=i,nstart=100)$cluster) > ##D cs <- as.data.frame(cs) > ##D names(cs) <- paste("V",2:12,sep="") > ##D ocs <- optile(cs,method="joint") > ##D cpcp(ocs,sort.individual=TRUE) > ##D # and set alpha-blending, show.dots = TRUE > ##D > ##D > ##D # and with hierarchical clusterings > ##D cs2 <- NULL > ##D library(amap) > ##D hc <- hcluster(BicatYeast) > ##D for(i in 2:20) cs2 <- cbind(cs2, subtree(hc,k=i)$data) > ##D cs2 <- as.data.frame(cs2) > ##D names(cs2) <- paste("V",2:20,sep="") > ##D cpcp(cs2,sort.individual=TRUE) > ##D # and set alpha-blending to about 0.6, show.dots = TRUE, then > ##D ss <- iset() > ##D ibar(ss$V6) > ##D # and VIEW >> Set color (rainbow) > ##D # Ideally the axes would be at a distance according to the heights of the cuts. > ##D # e.g. for the first 12 clusters (after that there are some cuts at about the same height) > ##D > ##D # the complete dendrogram doesn't look too attractive: > ##D plot(hc) > ##D > ##D # and plotting the top cuts only omits the information > ##D # on how many cases are in each node or leaf > ##D > ##D xcoords <- rev(tail(hc$height,11)) > ##D xcoords <- xcoords/max(hc$height) > ##D ycoords <- data.matrix(ss[,20:30]) > ##D ycoords <- apply(ycoords,2,function(s){ > ##D y <- s - min(s) > ##D y <- y/max(y) > ##D return(y) > ##D }) > ##D ycoords <- cbind(ycoords, as.integer(as.matrix(ss[,5]))) > ##D colv <- rainbow_hcl(6) > ##D dev.new() > ##D par(mfrow=c(1,2)) > ##D plot(1,pch="", xlim=c(0,1), ylim=c(min(xcoords)-0.007,1)) > ##D > ##D > ##D apply(ycoords,1,function(s){ > ##D points(x=s[-12], y=xcoords,) > ##D points(x=s[-12],y=xcoords,pch=19, col = colv[s[12]]) > ##D lines(x=s[-12], y=xcoords, col = colv[s[12]]) > ##D }) > ##D hc$height <- hc$height/max(hc$height) > ##D plclust(subtree(hc,12),hang=0.02) > ##D > ##D > ##D ############ ------------ EXAMPLE IV ------------ ############ > ##D # ------------------------- The Eisen Yeast data ------------------------- # > ##D library(biclust) > ##D data(EisenYeast) > ##D SEY <- scale(EisenYeast) > ##D > ##D Dby2 <- dist(SEY) > ##D > ##D hc1 <- hclust(Dby2, method = "ward") > ##D hc2 <- hclust(Dby2, method = "complete") > ##D > ##D hcc1 <- cutree(hc1, k = 16) > ##D km1 <- kmeans(scale(EisenYeast), centers = 16, nstart = 20, iter.max = 30)$cluster > ##D optile( table(hcc1, km1) ) > ##D > ##D > ##D ############ ------------ EXAMPLE V ------------ ############ > ##D # ------------------------- The Bicat Yeast data ------------------------- # > ##D > ##D # how many clusters are a good choice for kmeans? > ##D # one possible way to find out: > ##D # compute kmeans for 100 random initial settings, sort the results (clusters) > ##D # and compute their agreement > ##D # e.g. via Fleiss' Kappa (available in package irr) > ##D > ##D require(biclust) > ##D data(BicatYeast) > ##D require(irr) > ##D > ##D st <- Sys.time() > ##D fk <- NULL > ##D for(k in 3:8){ > ##D test <- subtable(replicate(100,kmeans(BicatYeast, centers = k)$cluster),1:100) > ##D test <- optile(test, fun = "casort") > ##D test <- optile(test, method="joint") > ##D test <- untableSet(test) > ##D for(i in 1:100) levels(test[,i]) <- 1:k > ##D fk <- c(fk,kappam.fleiss(test)$value) > ##D } > ##D Sys.time()-st > ##D plot(x = 3:8, y = fk, type="l", lwd=2) > ##D > ##D ############ ------------ EXAMPLE VI ------------ ############ > ##D # ------------------------- hierarchical clustering ------------------------- # > ##D > ##D # A list with hierarchical clustering objects: > ##D require(amap) > ##D > ##D hc1 <- hcluster(t(plants[,-1]), method="manhattan", link = "ward") > ##D hc2 <- hcluster(t(plants[,-1]), method="manhattan", link = "complete") > ##D > ##D hclist <- list(hc1, hc2) > ##D tfluctile( optile(hclist, k= c(8,8) ) ) > ##D > ##D # or a table with corresponding tree objects: > ##D > ##D tt <- table( subtree(hc1, 12)$data, subtree(hc2, 8)$data ) > ##D > ##D tfluctile(optile(tt, tree = list(hc1, hc2))) > ##D > ##D # only one tree object, the other variable is free: > ##D > ##D tt <- table( subtree(hc1, 8)$data, kk <- kmeans(t(plants[,-1]),centers=8)$cluster ) > ##D > ##D tfluctile(optile(tt, tree = list(hc1, NA))) > ##D > ## End(Not run) > > > > > > > > cleanEx() > nameEx("qBCI") > ### * qBCI > > flush(stderr()); flush(stdout()) > > ### Name: qBCI > ### Title: Quantile BCI > ### Aliases: qBCI.data.frame qBCI.default qBCI > > ### ** Examples > > ## Not run: > ##D qBCI(rnorm(100),runif(100)) > ##D > ##D > ##D # non-functional relationship: > ##D x1 <- runif(500,0,10) > ##D x2 <- runif(500,0,10) > ##D y1 <- x1+rnorm(500,sd=1) > ##D y2 <- 10-x2+rnorm(500,sd=1) > ##D > ##D x <- c(x1,x2) > ##D y <- c(y1,y2) > ##D > ##D plot(x,y, pch = 19) > ##D > ##D wdcor(x,y) > ##D 1 - qBCI(x,y) > ##D > ##D > ##D y1 <- x1+rnorm(500,sd=0.1) > ##D y2 <- 10-x2+rnorm(500,sd=0.1) > ##D > ##D x <- c(x1,x2) > ##D y <- c(y1,y2) > ##D > ##D plot(x,y, pch = 19) > ##D > ##D wdcor(x,y) > ##D 1 - qBCI(x,y) > ##D > ##D # or a quadratic curve: > ##D test <- sapply(seq(0,4,0.2),function(s){ > ##D x <- runif(200,-1,1) > ##D y <- 5+12*x^2+rnorm(200,sd=s) > ##D return(c(cor(x,y), > ##D wdcor(x,y), > ##D 1 - qBCI(x,y))) > ##D }) > ##D > ##D > ##D plot(test[3,],type="l", ylim=c(-0.2,1)) > ##D lines(test[1,], col = 2, lwd = 2) > ##D > ##D lines(test[2,], col = 3, lwd = 2) > ##D > ## End(Not run) > > > > > cleanEx() > nameEx("quickfechner") > ### * quickfechner > > flush(stderr()); flush(stdout()) > > ### Name: quickfechner > ### Title: fechnerian scaling > ### Aliases: quickfechner > > ### ** Examples > > data(olives) > #not a distance matrix, but a similarity matrix in some sense > cx <- 1-abs(cor(olives[-c(1,2,11)])) > > cx2 <- quickfechner(cx) > > rownames(cx2) <- names(olives)[-c(1,2,11)] > plot(hclust(as.dist(cx2))) > > dm <- matrix(runif(100),10,10) > dm <- dm+t(dm) > diag(dm) <- 0 > dm2 <- quickfechner(dm) > > dmS <- 1-dm/max(dm) > dmS2 <- quickfechner(dmS, x.type="sim", path.op = "*") > > ## Not run: > ##D # check triangular inequality: > ##D extracat:::trinq(dm) > ##D extracat:::trinq(dm2) > ##D extracat:::trinq(dmS2) > ## End(Not run) > > > > cleanEx() > nameEx("regmax") > ### * regmax > > flush(stderr()); flush(stdout()) > > ### Name: regmax > ### Title: Regular maximality > ### Aliases: regmin regmax > > ### ** Examples > > x <- replicate(20,rnorm(20)) > cx <- abs(cor(x)) > regmax(x) [1] FALSE > regmin(x) [1] FALSE > > diag(cx) = runif(20) > regmax(x) [1] FALSE > regmin(x) [1] FALSE > > > > > cleanEx() > nameEx("rmb") > ### * rmb > > flush(stderr()); flush(stdout()) > > ### Name: rmb > ### Title: Multiple Barchart for relative frequencies and generalized > ### Spineplots > ### Aliases: rmb rmb.formula rmb.table rmb.ftable rmb.glm > > ### ** Examples > > require(MASS) Loading required package: MASS > # simple example > rmb(formula = ~Type+Infl+Cont+Sat, data = housing, gap.mult = 2, + col.vars = c(FALSE,TRUE,TRUE,FALSE), label.opt = list(abbrev = 3)) > > # with sqrt-transformation and horizontal splits only > rmb(formula = ~Type+Infl+Cont+Sat, data = housing, gap.mult = 2, + col.vars = c(TRUE,TRUE,TRUE,TRUE), freq.trans = "sqrt", + label.opt = list(abbrev = 3) ) > > # a generalized spineplot with the first category highlighted > rmb(formula = ~Type+Infl+Cont+Sat, data = housing, spine = TRUE, + cat.ord = 1, mult = 2, col.vars = c(1,3,4), + freq.trans = list("sqrt",3), label.opt = list(abbrev = 2)) > ## Not run: > ##D > ##D # a generalized spineplot with all categories highlighted > ##D # in a changed order > ##D rmb(formula = ~Type+Infl+Cont+Sat, data = housing, spine = TRUE, > ##D cat.ord = c(3,1,2), gap.mult = 2, col.vars = c(TRUE,FALSE,TRUE,TRUE), > ##D freq.trans = "sqrt", label.opt = list(abbrev = 3)) > ##D > ##D # the barchart version only for categories 1 and 3 > ##D rmb(formula = ~Type+Infl+Cont+Sat, data = housing, > ##D cat.ord = c(1,3), gap.mult = 2, col.vars = c(TRUE,FALSE,TRUE,TRUE), > ##D freq.trans = "sqrt", label.opt = list(abbrev = c(4,1,1,1))) > ##D > ##D > ##D # with equal widths > ##D rmb(formula = ~Type+Infl+Cont+Sat, data = housing, eqwidth = TRUE, > ##D gap.mult = 2, col.vars = c(TRUE,FALSE,TRUE,TRUE), > ##D label.opt = list(abbrev = 2, lab.tv = TRUE)) > ##D > ##D # ----- models and residuals ----- # > ##D # using the logistic model: Sat by Type only > ##D > ##D # residual shadings and expected values > ##D rmb(formula = ~Type+Infl+Cont+Sat, data = housing, > ##D gap.mult = 2, col.vars = c(TRUE,FALSE,TRUE,TRUE), > ##D label.opt = list(abbrev = 3), expected = list(c(1,2,3),c(1,4)), > ##D model.opt = list(use.expected.values = TRUE, resid.display = "color") ) > ##D > ##D # residual values without shadings > ##D rmb(formula = ~Type+Infl+Cont+Sat, data = housing, > ##D gap.mult = 2, col.vars = c(TRUE,FALSE,TRUE,TRUE), > ##D label.opt = list(abbrev = 3), expected = list(c(1,2,3),c(1,4)), > ##D model.opt = list( resid.display = "values") ) > ##D > ##D # residual shadings and expected values > ##D rmb(formula = ~Type+Infl+Cont+Sat, data = housing, > ##D gap.mult = 2, col.vars = c(TRUE,FALSE,TRUE,TRUE), > ##D label.opt = list(abbrev = 3), expected = list(c(1,2,3),c(1,4)), > ##D model.opt = list(use.expected.values = TRUE, resid.display = "color") ) > ##D > ##D # barcharts with residual shadings and values > ##D rmb(formula = ~Type+Infl+Cont+Sat, data = housing, > ##D gap.mult = 2, col.vars = c(TRUE,FALSE,TRUE,TRUE), > ##D label.opt = list(abbrev = 3), expected = list(c(1,2,3),c(1,4)) ) > ##D > ##D # spineplots with residual shadings and values > ##D rmb(formula = ~Type+Infl+Cont+Sat, data = housing, spine = TRUE, > ##D gap.mult = 2, col.vars = c(TRUE,FALSE,TRUE,TRUE), > ##D label.opt = list(abbrev = 3), expected = list(c(1,2,3),c(1,4)) ) > ##D > ##D # piecharts with residual shadings and values > ##D rmb(formula = ~Type+Infl+Cont+Sat, data = housing, circular = TRUE, > ##D gap.mult = 2, col.vars = c(TRUE,FALSE,TRUE,TRUE), > ##D label.opt = list(abbrev = 3), expected = list(c(1,2,3),c(1,4)) ) > ##D > ##D # ----- using an ftable to create the plot ----- # > ##D tt = xtabs(Freq~Type+Cont+Infl+Sat, data = housing) > ##D ft = ftable(tt, col.vars= c(1,4)) > ##D rmb(tt) > ##D rmb(ft) > ##D > ##D # ----- using a glm model ----- # > ##D mod1 <- glm(Freq ~ Type*Infl*Cont + Type*Sat, data = housing, family = poisson) > ##D rmb(mod1, circular = TRUE, > ##D gap.mult = 2, col.vars = c(TRUE,FALSE,TRUE,TRUE), > ##D label.opt = list(abbrev = 3), model.opt = list(use.expected.values = TRUE) ) > ##D > ##D > ##D # ----- the numeric mode and cuts ----- # > ##D data(olives) > ##D # only three cuts to show how it works > ##D rmb(~palmitoleic+stearic+Region, data = olives, cut = c(3,3,0)) > ##D > ##D require(ggplot2) > ##D data(diamonds) > ##D diamonds$lprice <- log(diamonds$price) > ##D # a minority of extreme observations mess the display up: > ##D rmb(~depth+table+lprice, data = diamonds, eqwidth = TRUE, spine = TRUE, > ##D cut = c(36,36,5), col = "seq", num.mode = TRUE) > ##D > ##D # we can zoom in via innerval: > ##D rmb(~depth+table+lprice, data = diamonds, circular = TRUE, > ##D cut = c(36,36,5), col = "div", innerval = 0.95, > ##D num.mode = TRUE, freq.trans ="log") > ##D > ##D # price, carat and color > ##D diamonds$lprice <- log(diamonds$price) > ##D diamonds$lcarat <- log(diamonds$carat) > ##D rmb(~lcarat+lprice+color, data = diamonds, > ##D cut = c(24,24,0), col = "rgb", num.mode = TRUE, > ##D freq.trans="sqrt", eqwidth=TRUE, max.scale=0.5) > ##D > ## End(Not run) > > > > cleanEx() detaching ‘package:MASS’ > nameEx("rmbmat") > ### * rmbmat > > flush(stderr()); flush(stdout()) > > ### Name: rmbmat > ### Title: Pairwise RMB-Plots > ### Aliases: rmbmat > > ### ** Examples > > data(olives) > > > ## Not run: > ##D > ##D # mode = "c" piecharts are currently slow > ##D > ##D rmbmat(olives, tv=2, mode = "s") > ##D > ##D rmbmat(olives[,1:5], tv=2, col ="div", plot.tv = TRUE, > ##D lower.opt = list(tv2 = 1, col ="rgb")) > ##D > ##D rmbmat(olives[,c(1:5,11)], tv=2, > ##D upper.opt=list(mode="s", eqwidth = TRUE), > ##D rc.opt = list( c5 = list(eqwidth=FALSE,mode="s"), > ##D r5 = list(eqwidth=TRUE, mode="s")),allocation=NULL) > ## End(Not run) > > > > > cleanEx() > nameEx("scpcp") > ### * scpcp > > flush(stderr()); flush(stdout()) > > ### Name: scpcp > ### Title: Static Categorical Parallel Coordinates Plot > ### Aliases: scpcp > > ### ** Examples > > > data(Titanic) > titanic <- as.data.frame(Titanic) > > scpcp(titanic) > > #scpcp(titanic, level.width=0) > > #scpcp(titanic, gap=0) > > #default with highlighting > scpcp(titanic, sel="data[,4]") > > # random colors like for instance from a clustering > scpcp(titanic, sel="sample(1:6,nrow(data),T)") > > # another one with some formal changes > require(scales) Loading required package: scales > scpcp(data=titanic,sel="Sex=='Male' & Survived=='Yes'", sel.palette = "w", + col.opt=list(alpha=0.7,border=alpha(1,0.3)), gap = 0.5, level.width= 0.3) > > ## Not run: > ##D > ##D # mushroom data from the UCI machine learning repository > ##D data(agaricus) > ##D MR <- agaricus > ##D > ##D levels(MR$stalk_root) <- c(levels(MR$stalk_root),"N/A") > ##D MR$stalk_root[which(is.na(MR$stalk_root))] <- "N/A" > ##D > ##D op <- optile(MR[,1:12], method="joint") > ##D > ##D > ##D scpcp(op, sel = "odor",sel.palette="w", > ##D col.opt = list(border = alpha(1,0.1)), lab.opt=list(rot=45)) > ##D > ##D > ##D # ADAC ecotest data with four clusterings (k-means, mclust, hc Ward, hc complete) > ##D data(eco) > ##D > ##D # illustrate reordering success using coloring > ##D scpcp(eco[,13:16], sel = "data[,1]", sel.palette="d") > ##D > ##D scpcp(optile(eco[,13:16]), sel = "data[,1]", sel.palette="d", > ##D col.opt = list(border=alpha(1,0.1))) > ##D > ##D # car classes (lower to upper class) > ##D eco$Klasse <- factor(eco$Klasse, levels = levels(eco$Klasse)[c(3,1,2,7,4,5,6)]) > ##D > ##D scpcp(eco[,17:20], sel = eco$Klasse, sel.palette="s", col.opt = list(h=140)) > ##D > ##D # the color variable included > ##D scpcp(eco[,c(3,17:20)], sel = eco$Klasse, sel.palette="s", > ##D col.opt = list(h=140),lab.opt = list(abbr=5)) > ## End(Not run) > > > > cleanEx() detaching ‘package:scales’ > nameEx("setcover") > ### * setcover > > flush(stderr()); flush(stdout()) > > ### Name: setcover > ### Title: greedy setcover optimisation > ### Aliases: setcover > > ### ** Examples > > # compute 100 clusterings with 24 clusters each: > sc <- scale(olives[,3:10]) > km100 <- as.data.frame(replicate(100, kmeans(sc,centers = 24)$cluster)) > > # convert to indicator matrix > I100 <- idat(km100) > > # select from all clusters a minimum set: > scover <- setcover(as.matrix(I100)) > > > cdata <- subtable( + as.data.frame(cbind(olives[,1:2], + I100[,scover])),1:(length(scover)+2)) > scpcp(cdata,sel="Area") > > > > > > > cleanEx() > nameEx("sortandcut") > ### * sortandcut > > flush(stderr()); flush(stdout()) > > ### Name: sortandcut > ### Title: Sort-and-Cut Reordering > ### Aliases: sortandcut > > ### ** Examples > > M <- arsim(12000,c(30,40),7,noise=0.3) > c1 <- cfluctile(M1<-optile(M, iter = 20)) > c2 <- cfluctile(M2<-sortandcut(M)) optile.c:1538:12: runtime error: index 2 out of bounds for type 'float [*]' #0 0x7f203425da97 in getclust /data/gannet/ripley/R/packages/tests-gcc-SAN/extracat/src/optile.c:1538 #1 0x574edb in do_dotcall /data/gannet/ripley/R/svn/R-devel/src/main/dotcode.c:1252 #2 0x62393d in bcEval /data/gannet/ripley/R/svn/R-devel/src/main/eval.c:7283 #3 0x64588f in Rf_eval /data/gannet/ripley/R/svn/R-devel/src/main/eval.c:620 #4 0x64af95 in R_execClosure /data/gannet/ripley/R/svn/R-devel/src/main/eval.c:1780 #5 0x64d588 in Rf_applyClosure /data/gannet/ripley/R/svn/R-devel/src/main/eval.c:1706 #6 0x62c4f3 in bcEval /data/gannet/ripley/R/svn/R-devel/src/main/eval.c:6733 #7 0x64588f in Rf_eval /data/gannet/ripley/R/svn/R-devel/src/main/eval.c:620 #8 0x64af95 in R_execClosure /data/gannet/ripley/R/svn/R-devel/src/main/eval.c:1780 #9 0x64d588 in Rf_applyClosure /data/gannet/ripley/R/svn/R-devel/src/main/eval.c:1706 #10 0x645d93 in Rf_eval /data/gannet/ripley/R/svn/R-devel/src/main/eval.c:743 #11 0x6522e1 in do_set /data/gannet/ripley/R/svn/R-devel/src/main/eval.c:2807 #12 0x646419 in Rf_eval /data/gannet/ripley/R/svn/R-devel/src/main/eval.c:695 #13 0x6475a7 in forcePromise /data/gannet/ripley/R/svn/R-devel/src/main/eval.c:516 #14 0x648203 in FORCE_PROMISE /data/gannet/ripley/R/svn/R-devel/src/main/eval.c:4897 #15 0x648203 in getvar /data/gannet/ripley/R/svn/R-devel/src/main/eval.c:4970 #16 0x622ef9 in bcEval /data/gannet/ripley/R/svn/R-devel/src/main/eval.c:6517 #17 0x64588f in Rf_eval /data/gannet/ripley/R/svn/R-devel/src/main/eval.c:620 #18 0x6475a7 in forcePromise /data/gannet/ripley/R/svn/R-devel/src/main/eval.c:516 #19 0x645ae0 in Rf_eval /data/gannet/ripley/R/svn/R-devel/src/main/eval.c:656 #20 0x617944 in bcEval /data/gannet/ripley/R/svn/R-devel/src/main/eval.c:6765 #21 0x64588f in Rf_eval /data/gannet/ripley/R/svn/R-devel/src/main/eval.c:620 #22 0x64af95 in R_execClosure /data/gannet/ripley/R/svn/R-devel/src/main/eval.c:1780 #23 0x64d588 in Rf_applyClosure /data/gannet/ripley/R/svn/R-devel/src/main/eval.c:1706 #24 0x62c4f3 in bcEval /data/gannet/ripley/R/svn/R-devel/src/main/eval.c:6733 #25 0x64588f in Rf_eval /data/gannet/ripley/R/svn/R-devel/src/main/eval.c:620 #26 0x64af95 in R_execClosure /data/gannet/ripley/R/svn/R-devel/src/main/eval.c:1780 #27 0x64d588 in Rf_applyClosure /data/gannet/ripley/R/svn/R-devel/src/main/eval.c:1706 #28 0x645d93 in Rf_eval /data/gannet/ripley/R/svn/R-devel/src/main/eval.c:743 #29 0x6522e1 in do_set /data/gannet/ripley/R/svn/R-devel/src/main/eval.c:2807 #30 0x646419 in Rf_eval /data/gannet/ripley/R/svn/R-devel/src/main/eval.c:695 #31 0x6bd93e in Rf_ReplIteration /data/gannet/ripley/R/svn/R-devel/src/main/main.c:260 #32 0x6bd93e in Rf_ReplIteration /data/gannet/ripley/R/svn/R-devel/src/main/main.c:200 #33 0x6bdff0 in R_ReplConsole /data/gannet/ripley/R/svn/R-devel/src/main/main.c:310 #34 0x6be124 in run_Rmainloop /data/gannet/ripley/R/svn/R-devel/src/main/main.c:1086 #35 0x4180e8 in main /data/gannet/ripley/R/svn/R-devel/src/main/Rmain.c:29 #36 0x7f20446d911a in __libc_start_main (/lib64/libc.so.6+0x2311a) #37 0x41a819 in _start (/data/gannet/ripley/R/gcc-SAN/bin/exec/R+0x41a819) ================================================================= ==40262==ERROR: AddressSanitizer: dynamic-stack-buffer-overflow on address 0x7ffde4972be8 at pc 0x7f203425d99f bp 0x7ffde4972a30 sp 0x7ffde4972a20 WRITE of size 4 at 0x7ffde4972be8 thread T0 #0 0x7f203425d99e in getclust /data/gannet/ripley/R/packages/tests-gcc-SAN/extracat/src/optile.c:1538 #1 0x574edb in do_dotcall /data/gannet/ripley/R/svn/R-devel/src/main/dotcode.c:1252 #2 0x62393d in bcEval /data/gannet/ripley/R/svn/R-devel/src/main/eval.c:7283 #3 0x64588f in Rf_eval /data/gannet/ripley/R/svn/R-devel/src/main/eval.c:620 #4 0x64af95 in R_execClosure /data/gannet/ripley/R/svn/R-devel/src/main/eval.c:1780 #5 0x64d588 in Rf_applyClosure /data/gannet/ripley/R/svn/R-devel/src/main/eval.c:1706 #6 0x62c4f3 in bcEval /data/gannet/ripley/R/svn/R-devel/src/main/eval.c:6733 #7 0x64588f in Rf_eval /data/gannet/ripley/R/svn/R-devel/src/main/eval.c:620 #8 0x64af95 in R_execClosure /data/gannet/ripley/R/svn/R-devel/src/main/eval.c:1780 #9 0x64d588 in Rf_applyClosure /data/gannet/ripley/R/svn/R-devel/src/main/eval.c:1706 #10 0x645d93 in Rf_eval /data/gannet/ripley/R/svn/R-devel/src/main/eval.c:743 #11 0x6522e1 in do_set /data/gannet/ripley/R/svn/R-devel/src/main/eval.c:2807 #12 0x646419 in Rf_eval /data/gannet/ripley/R/svn/R-devel/src/main/eval.c:695 #13 0x6475a7 in forcePromise /data/gannet/ripley/R/svn/R-devel/src/main/eval.c:516 #14 0x648203 in FORCE_PROMISE /data/gannet/ripley/R/svn/R-devel/src/main/eval.c:4897 #15 0x648203 in getvar /data/gannet/ripley/R/svn/R-devel/src/main/eval.c:4970 #16 0x622ef9 in bcEval /data/gannet/ripley/R/svn/R-devel/src/main/eval.c:6517 #17 0x64588f in Rf_eval /data/gannet/ripley/R/svn/R-devel/src/main/eval.c:620 #18 0x6475a7 in forcePromise /data/gannet/ripley/R/svn/R-devel/src/main/eval.c:516 #19 0x645ae0 in Rf_eval /data/gannet/ripley/R/svn/R-devel/src/main/eval.c:656 #20 0x617944 in bcEval /data/gannet/ripley/R/svn/R-devel/src/main/eval.c:6765 #21 0x64588f in Rf_eval /data/gannet/ripley/R/svn/R-devel/src/main/eval.c:620 #22 0x64af95 in R_execClosure /data/gannet/ripley/R/svn/R-devel/src/main/eval.c:1780 #23 0x64d588 in Rf_applyClosure /data/gannet/ripley/R/svn/R-devel/src/main/eval.c:1706 #24 0x62c4f3 in bcEval /data/gannet/ripley/R/svn/R-devel/src/main/eval.c:6733 #25 0x64588f in Rf_eval /data/gannet/ripley/R/svn/R-devel/src/main/eval.c:620 #26 0x64af95 in R_execClosure /data/gannet/ripley/R/svn/R-devel/src/main/eval.c:1780 #27 0x64d588 in Rf_applyClosure /data/gannet/ripley/R/svn/R-devel/src/main/eval.c:1706 #28 0x645d93 in Rf_eval /data/gannet/ripley/R/svn/R-devel/src/main/eval.c:743 #29 0x6522e1 in do_set /data/gannet/ripley/R/svn/R-devel/src/main/eval.c:2807 #30 0x646419 in Rf_eval /data/gannet/ripley/R/svn/R-devel/src/main/eval.c:695 #31 0x6bd93e in Rf_ReplIteration /data/gannet/ripley/R/svn/R-devel/src/main/main.c:260 #32 0x6bd93e in Rf_ReplIteration /data/gannet/ripley/R/svn/R-devel/src/main/main.c:200 #33 0x6bdff0 in R_ReplConsole /data/gannet/ripley/R/svn/R-devel/src/main/main.c:310 #34 0x6be124 in run_Rmainloop /data/gannet/ripley/R/svn/R-devel/src/main/main.c:1086 #35 0x4180e8 in main /data/gannet/ripley/R/svn/R-devel/src/main/Rmain.c:29 #36 0x7f20446d911a in __libc_start_main (/lib64/libc.so.6+0x2311a) #37 0x41a819 in _start (/data/gannet/ripley/R/gcc-SAN/bin/exec/R+0x41a819) Address 0x7ffde4972be8 is located in stack of thread T0 SUMMARY: AddressSanitizer: dynamic-stack-buffer-overflow /data/gannet/ripley/R/packages/tests-gcc-SAN/extracat/src/optile.c:1538 in getclust Shadow bytes around the buggy address: 0x10003c926520: 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 0x10003c926530: 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 0x10003c926540: 00 00 00 00 00 00 00 00 ca ca ca ca 00 cb cb cb 0x10003c926550: cb cb cb cb 00 00 00 00 ca ca ca ca 00 04 cb cb 0x10003c926560: cb cb cb cb 00 00 00 00 ca ca ca ca 00 cb cb cb =>0x10003c926570: cb cb cb cb 00 00 00 00 ca ca ca ca 00[cb]cb cb 0x10003c926580: cb cb cb cb 00 00 00 00 ca ca ca ca 00 cb cb cb 0x10003c926590: cb cb cb cb 00 00 00 00 ca ca ca ca 00 04 cb cb 0x10003c9265a0: cb cb cb cb 00 00 00 00 00 00 00 00 00 00 00 00 0x10003c9265b0: 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 0x10003c9265c0: 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 Shadow byte legend (one shadow byte represents 8 application bytes): Addressable: 00 Partially addressable: 01 02 03 04 05 06 07 Heap left redzone: fa Freed heap region: fd Stack left redzone: f1 Stack mid redzone: f2 Stack right redzone: f3 Stack after return: f5 Stack use after scope: f8 Global redzone: f9 Global init order: f6 Poisoned by user: f7 Container overflow: fc Array cookie: ac Intra object redzone: bb ASan internal: fe Left alloca redzone: ca Right alloca redzone: cb ==40262==ABORTING