• QR Code (size=2)
• QR Code (size=3)
• QR Code (size=4)
• QR Code (size=5)
• QR Code (size=6)

3,354595631
3,765288495
3,816359346
3,666661408
3,537583626
3,531334899
3,938206822
3,306909236
3,082770414
3,679729208
3,781144127
4,742305152
4,299209706
3,841940766
4,276800898
4,360646391
4,422651012
3,992644258
3,883843547
3,303744701
3,904086072
3,111227099
4,006095278
4,468650377
4,005163183
2,873406334
3,319584667
3,586209976
3,972423428
3,975193819
4,175809138
3,926660672
4,003782856
4,072211732
4,20789002
3,018201225
1,323202583
3,947106465
4,217637039
3,931942654
3,958184667
4,033297466
4,026233613
3,716835407
3,777074278
3,766441197
3,90536538
4,288570912
2,911348477
4,126375473
4,055320609
3,638041895
3,957925506
4,152097964
4,256071901
3,895358832
4,143451688
4,361644085
4,3485742
4,671668826
4,262942655
4,052084641
4,313492064
4,200703304
3,909605829
3,828153891
4,038881188
4,219168363
4,002800789
4,0264848
3,593100571
4,088538924
4,471676643
4,011181573
4,090386547
3,738568163
3,468065378
3,419534958
3,627465526
3,647778613
3,857337514
3,414487594
3,619765825
3,726710771
3,66437674
3,976795763
3,677249511
3,709617062
3,434932709
3,702026933
4,750739078
4,003524382
2,670246616
4,124065986
4,029225806
4,334671206
4,439721377
4,220873256
4,582562828
4,305419877
4,210342703
4,191874454
4,163996854
3,184738806
3,540499148
4,352697843
4,179809246
4,61883965
4,286059523
4,359753191
4,268360174
4,09177417
3,318701647
5,344668461
4,7953896
4,879263659
4,978011733
4,897137294
5,246706646
4,57496349
4,227328112
4,426896684
5,152293344
4,867037718
4,495000004
4,104748186
3,884479853
4,356112047
4,371002635
4,372176881
4,161286719
4,302088231
4,251924969
4,033491361
4,208218657
4,321556305
4,437700264
4,597359075
4,086812798
4,591552635
4,213403684
4,517374034
2,79170247
3,343260212
3,263034247
3,534281144
3,393242967
4,399944597
3,519044024
4,122154262
3,826474517
4,808992261
4,718174137
4,343239705
4,187699832
4,741908428
4,769976785
4,016946409
4,88771766
4,706395682
4,351683343
4,261830165
4,376627508
4,821568285
4,933294278
4,662669547
4,55557536
3,646786751
4,670772762
4,700324125
4,654750058
3,646517154
3,502416105
4,176055006
3,879989371
3,932647095
4,815455461
5,062285967
4,941087096
4,867498295
4,74537649
4,78553469
4,078596827
4,469918021
3,964440564
4,181157506
3,929216691
5,086542094
3,985341135
4,417682562
4,671229504
4,667920187
3,984408538
3,395764524
4,669842481
4,83609456
3,84715748
3,572982263
3,771444364
4,439150474
4,045708334
3,442106412
4,346639862
4,067095794
4,558112162
4,094846697
4,430798143
4,311354565
4,303493896
5,245811435
3,515452581
5,043674602
3,576040345
3,950161385
3,875263377
3,588228866
4,490962078
3,732392099
3,537979165
4,142155981
3,319831983
1,4793112
3,515695274
4,199119576
3,845030482
3,157259172
3,694698333
4,555949661
4,095589581
4,270536572
4,309445693
4,694696568
4,456961925
4,352092942
3,345477248
4,310691686
2,284567693
4,337570021
4,036482123
4,315536093
3,859827055
3,857576609
3,597761771
4,227414337
3,626846671
3,945455242
3,94552392
4,55491198
4,13760541
4,283369779
3,22456445
4,151986864
3,931127918
3,954510848
4,155130429
4,933762615
2,814835073
4,102741477
3,742060733
4,214670298
4,02716703
3,417806625
3,97236263
4,683555741
4,266208215
4,944508278
3,902180244
4,159001548
4,222120394
4,848643301
2,909373294
4,066865813
2,767358044
4,080607109
4,608937438
3,517106378
3,922544156
4,326245946
4,047081344
4,056492226
4,311795194
3,427730435
3,429701925
3,434555466
4,106353158
3,566952775
2,676312356
3,080262361
3,564164629
3,77381408
4,304359271
3,232615332
4,071146021
3,974270096
4,114595565
4,448630228
4,534591683
4,172320715
3,886279994
4,687824328
2,774825375
4,366384222
4,242283199
4,551600014
3,769957956
3,626059301
3,27372696
4,30573921
4,263159167
4,296335502
3,832471681
3,330651026
4,24828024
4,232802091
4,453275449
3,909679986
5,219026074
2,465511018
4,552415567
2,857790335
4,073333695
3,448772712
3,746738403
4,071620532
3,781161325
4,437818674
3,664394494
3,197164057
3,833994693
3,937229735
4,197923875
4,419571651
3,69373398
3,773301142
4,297295923
2,719172729
3,165828704
4,119127773
3,491829516
4,055326843
3,358529791
3,447935321
3,991684615
4,135273601
4,540142695
3,689762393
4,221990257
3,008818729
4,031306606
4,249705982
3,83616508
3,656507217
4,201487276
4,499030381
4,614467673
3,849513596
4,190714888
4,114644379
4,588845475
4,070364171
4,125528633
2,848142315
3,886836561
3,923268229
3,434875088
4,915079033
4,314856507
3,32379085
4,215691983
3,829865888
4,574330925
3,736601305
2,87160698
3,406603254
3,889991962
3,4773354
4,44516106
3,161162536
3,579960584
3,270981244
4,242939347
3,490087019
4,239953487
3,900653831
4,308937431
4,515527509
4,249720202
3,818151062
3,14136786
4,065244885
4,551067212
3,6200737
2,700397503
3,906224615
3,78621707
3,606776807
3,440285952
3,90935005
4,043864016
3,552315677
4,655198704
4,575837318
3,680317627
3,716810549
4,370768119
2,656974095
4,084168135
4,092998569
5,337324371
4,054084838
3,959216951
3,925667377
3,869231551
4,075111956
3,916907637
4,606626225
3,952450531
4,242478544
3,815622671
4,1450426
3,509267805
3,794917126
4,05680567
3,895146862
3,438647005
3,360000229
2,945721158
4,186029744
4,377085875
4,130815877
4,714706841
4,072109785
4,241717722
4,59059781
3,449170135
3,408774486
3,285662075
3,054194825
5,041794537
4,582301262
3,869265135
3,701459363
4,50215827
5,051529682
3,253506433
3,751210653
4,592503433
3,717118151
3,692163035
4,76559586
4,485122702
4,65422764
4,626968924
4,182284106
5,29098114
3,98318132
3,745938715
4,349354836
3,827950403
4,740474016
3,560605948
4,353247419
4,729193381
4,795425917
4,481746002
4,534411498
3,564053403
3,329562548
3,670882561
3,854815332
3,587084838
3,938078115
4,599025853
4,347332439
4,165140475
3,779673479
4,872691527
4,419007184
3,521674132
4,603719294
4,025834613
4,144018078
4,420792648
4,385010053
3,911624861
4,770300637
4,779481496
4,545663354
4,574094202
4,583719861
4,416132467
3,367022983
5,061959165
3,893613096
4,337235183
3,686510175
5,02020714
5,247625003
4,485497718
4,832290518
4,436361966
4,702671427
4,007034536
4,968257849
4,619419581
4,582450694
3,550579518
3,936005347
4,186185671
4,830554081
3,827615539
3,522833308
4,710634079
4,818492346
4,74107749
3,071935359
4,437768493
4,169669174
4,168229246
3,686974478
3,076232617
4,571765499
4,171567449
4,260983122
3,494271467
3,821267136
3,674777041
4,372992526
4,07024082
5,318732112
3,0182856
3,765859897
4,496893801
3,454737168
4,09616644
3,965166679
4,631261092
3,084375852

0,231463241
0,056332217
0,058579089
0,032835901
0,072230816
0,051412707
0,04547652
0,033301079
0,051560549
0,098982255
0,246387377
0,122907639
0,117662887
0,115119103
0,14229804
0,094054505
0,112609609
0,104907062
0,12501527
0,173981899
0,1346069
0,185030475
0,353470785
0,102810865
0,152383802
0,125738445
0,136322469
0,14131693
0,096000585
0,118643112
0,118554066
0,149525604
0,123060113
0,062061521
0,05280222
0,145518472
0,099797174
0,050089717
0,126341087
0,13329194
0,120973458
0,06910583
0,063707519
0,053241136
0,055731351
0,088267065
0,109543843
0,118684371
0,068175885
0,074257828
0,11753943
0,064573861
0,0997874
0,102823912
0,085042304
0,13365084
0,151161732
0,14101135
0,104323561
0,114586524
0,104999465
0,140352629
0,134249797
0,141250906
0,098894211
0,150710474
0,148098637
0,203535569
0,116374482
0,107061325
0,127128004
0,130198204
0,120527982
0,119433284
0,112375711
0,143762569
0,110968645
0,003393768
0,076343176
0,095984276
0,195907209
0,189753367
0,179633879
0,187588421
0,183222659
0,023661491
0,226806862
0,186063761
0,161941481
0,153313729
0,051337439
0,241935872
0,151438412
0,256704024
0,25920541
0,234693223
0,260982232
0,213168104
0,197431241
0,250008209
0,145116834
0,173659091
0,159629318
0,157282824
0,225074876
0,271385299
0,168724948
0,265635691
0,192035894
0,213507626
0,248773788
0,220778192
0,110615475
0,112287757
0,086221116
0,095999116
0,115804677
0,108184971
0,086871512
0,219177619
0,125294715
0,143634915
0,065771473
0,097485647
0,101561161
0,182855831
0,14968078
0,146179839
0,15918638
0,140934744
0,184307083
0,138801857
0,142664259
0,228112387
0,182940472
0,159473657
0,125069031
0,142657099
0,172497944
0,136725051
0,156387597
0,155811191
0,137150433
0,151341221
0,140467741
0,050755545
0,122621849
0,044287725
0,067252742
0,062319013
0,122011657
0,164552883
0,133679213
0,090213107
0,088058391
0,100408516
0,079625053
0,066033005
0,100406438
0,201972041
0,125093971
0,19323878
0,111479534
0,141543421
0,099997222
0,118555319
0,099315632
0,100547629
0,136319695
0,119852407
0,113024949
0,071054354
0,089400526
0,089703026
0,088902739
0,085188059
0,094816788
0,096425071
0,080549438
0,118752295
0,091619463
0,117693237
0,045153268
0,076908891
0,108351186
0,137207879
0,152813404
0,096673576
0,112359886
0,082342316
0,104762723
0,092698802
0,031424536
0,140687402
0,11108691
0,15299485
0,173127129
0,111195266
0,159250133
0,09122923
0,1765613
0,110727672
0,201688092
0,104935583
0,169108602
0,135144539
0,071907654
0,045958525
0,08436154
0,119368324
0,15974711
0,171197397
0,038300671
0,111544343
0,208448007
0,13907005
0,122673575
0,117762114
0,133020776
0,056967926
0,22236036
0,12963826
0,24508863
0,062631845
0,119036301
0,135420407
0,204814069
0,068702908
0,196649527
0,056604999
0,049557591
0,092370401
0,049132798
0,181174566
0,110208226
0,056820497
0,174654916
0,055474345
0,045056922
0,058106916
0,158875156
0,055806094
0,205400227
0,037838434
0,063976972
0,040068531
0,039885274
0,051985912
0,04670697
0,186139591
0,163605523
0,133987956
0,044282282
0,148758808
0,048841775
0,104435429
0,054165431
0,190848502
0,038025189
0,196974108
0,16478181
0,144157776
0,050702193
0,157612162
0,044638184
0,037756934
0,208238499
0,054703373
0,123094784
0,116961213
0,053911583
0,135930038
0,061506126
0,178041562
0,242032967
0,175120194
0,25635669
0,041888672
0,167476325
0,161035452
0,144851773
0,180980136
0,068009603
0,0917839
0,146626396
0,045328468
0,077030869
0,050591991
0,122206036
0,049808681
0,156842315
0,169797484
0,049269511
0,068919065
0,081507334
0,062460225
0,137752231
0,147388088
0,135833355
0,067673869
0,154959413
0,169425515
0,133444047
0,042402921
0,202172019
0,23178479
0,077535492
0,090622745
0,166875055
0,069543072
0,055025886
0,16020537
0,052537867
0,188636739
0,173591443
0,043226948
0,133838005
0,043818822
0,204974293
0,056808017
0,081723452
0,056042011
0,036941598
0,030294646
0,072347875
0,124184454
0,053805519
0,23418091
0,140896023
0,112530632
0,060014408
0,131233027
0,141505598
0,183440749
0,189542499
0,172847744
0,145446416
0,190672398
0,229100999
0,200600741
0,057537051
0,247545879
0,082636143
0,158988242
0,074167793
0,1307277
0,141373018
0,091629915
0,057578017
0,095670375
0,045041518
0,066231837
0,079641733
0,133937833
0,132126298
0,059378512
0,172447619
0,04574125
0,151608972
0,161463693
0,138568132
0,169063584
0,05528272
0,058851894
0,051521654
0,184908172
0,126068914
0,178190574
0,160272495
0,183258786
0,170339874
0,119770683
0,141134485
0,123563226
0,190170825
0,207516572
0,050161657
0,086290869
0,051316305
0,040241011
0,153145474
0,19818924
0,16727982
0,201504922
0,058356249
0,180317809
0,113675585
0,046454538
0,132419627
0,06340209
0,095904098
0,114036673
0,046864031
0,207095319
0,081353893
0,042890101
0,174318731
0,174905262
0,099565726
0,147535083
0,053232382
0,129606112
0,07722415
0,140787658
0,038971912
0,256925709
0,170693375
0,177259157
0,050348625
0,106656927
0,044818894
0,128240041
0,216564324
0,049092916
0,279130165
0,191637418
0,05407796
0,074615547
0,155456653
0,2160069
0,145980869
0,036308904
0,069357308
0,15221576
0,130239313
0,180602063
0,125387621
0,202188091
0,190118232
0,179264848
0,138279639
0,112467964
0,119099348
0,116046423
0,310578546
0,232011124
0,131795764
0,106566636
0,195656583
0,136930997
0,113884534
0,097616313
0,142454335
0,244285071
0,152941523
0,136144354
0,144138515
0,138178331
0,145432042
0,137673815
0,207690416
0,133867444
0,189798305
0,147196012
0,131951566
0,092726608
0,158389255
0,13760746
0,119912039
0,155220759
0,177463835
0,128597873
0,08873667
0,117522688
0,176647313
0,129615951
0,143220177
0,111543724
0,131681515
0,142215989
0,13023405
0,122716747
0,248242269
0,102734547
0,173459475
0,172083852
0,08138481
0,260188795
0,223073043
0,132200948
0,148149065
0,092242561
0,192986564
0,141467926
0,130034057
0,157360243
0,152386298
0,204958741
0,165751664
0,097215117
0,129862404
0,110280448
0,165677788
0,210611441
0,162729798
0,109258468
0,111602522
0,140629865
0,151776751
0,26610099
0,158761901
0,154054083
0,161903466
0,094590263
0,165364044
0,265541259
0,121135232
0,103710329
0,173058146
0,117001791
0,098116019
0,096838676
0,146920703
0,112977584
0,185701873
0,380704318
0,091738771
0,287250626
0,146210249
0,123086556
0,18971046
0,123417056
0,302584337
0,100298083
0,184217601
0,168748703
0,138991259
0,433062022
0,159146013
0,156797186
0,217854633
0,274927383

par1 <- as.numeric(par1) #factor
if (par2 == 'TRUE') par2 <- TRUE else par2 <- FALSE
if (par3 == 'TRUE') par3 <- TRUE else par3 <- FALSE
library(rpart)
compute.bagplot<-function(x,y,
factor=3, # expanding factor for bag to get the loop
approx.limit=300, # limit
dkmethod=2, # in 1:2; there are two methods for approximating the bag
precision=1, # controls precisionn of computation
verbose=FALSE,debug.plots='no' # tools for debugging
){
win<-function(dx,dy){  atan2(y=dy,x=dx) }
out.of.polygon<-function(xy,pg){
if(nrow(pg)==1) return(pg)
pgcenter<-apply(pg,2,mean)
pg<-cbind(pg[,1]-pgcenter[1],pg[,2]-pgcenter[2])
xy<-cbind(xy[,1]-pgcenter[1],xy[,2]-pgcenter[2])
extr<-rep(FALSE,nrow(xy))
for(i in seq(nrow(xy))){
alpha<-sort((win(xy[i,1]-pg[,1],xy[i,2]-pg[,2]))%%(2*pi))
extr[i]<-pipi<(alpha[1]+2*pi-alpha[length(alpha)])
}
print(extr)
}
cut.z.pg<-function(zx,zy,p1x,p1y,p2x,p2y){
a2<-(p2y-p1y)/(p2x-p1x); a1<-zy/zx
sx<-(p1y-a2*p1x)/(a1-a2); sy<-a1*sx
sxy<-cbind(sx,sy)
h<-any(is.nan(sxy))||any(is.na(sxy))||any(Inf==abs(sxy))
if(h){
if(!exists('verbose')) verbose<-FALSE
if(verbose) cat('special')
h<-0==(a1-a2) & sign(zx)==sign(p1x)
sx<-ifelse(h,p1x,sx); sy<-ifelse(h,p1y,sy)
h<-0==(a1-a2) & sign(zx)!=sign(p1x)
sx<-ifelse(h,p2x,sx); sy<-ifelse(h,p2y,sy)
h<-p1x==p2x & zx!=p1x & p1x!=0
sx<-ifelse(h,p1x,sx); sy<-ifelse(h,zy*p1x/zx,sy)
h<-p1x==p2x & zx!=p1x & p1x==0
sx<-ifelse(h,p1x,sx); sy<-ifelse(h,0,sy)
h<-p1x==p2x & zx==p1x & p1x==0 & sign(zy)==sign(p1y)
sx<-ifelse(h,p1x,sx); sy<-ifelse(h,p1y,sy)
h<-p1x==p2x & zx==p1x & p1x==0 & sign(zy)!=sign(p1y)
sx<-ifelse(h,p1x,sx); sy<-ifelse(h,p2y,sy)
h<-zx==p1x & zy==p1y; sx<-ifelse(h,p1x,sx); sy<-ifelse(h,p1y,sy)
h<-zx==p2x & zy==p2y; sx<-ifelse(h,p2x,sx); sy<-ifelse(h,p2y,sy)
h<-zx==0 & zy==0; sx<-ifelse(h,0,sx); sy<-ifelse(h,0,sy)
sxy<-cbind(sx,sy)
} # end of special cases
if(!exists('debug.plots')) debug.plots<-'no'
if(debug.plots=='all'){
segments(sxy[,1],sxy[,2],zx,zy,col='red')
segments(0,0,sxy[,1],sxy[,2],type='l',col='green',lty=2)
points(sxy,col='red')
}
return(sxy)
}
find.cut.z.pg<-function(z,pg,center=c(0,0),debug.plots='no'){
if(!is.matrix(z)) z<-rbind(z)
if(1==nrow(pg)) return(matrix(center,nrow(z),2,TRUE))
n.pg<-nrow(pg); n.z<-nrow(z)
z<-cbind(z[,1]-center[1],z[,2]-center[2])
pgo<-pg; pg<-cbind(pg[,1]-center[1],pg[,2]-center[2])
if(!exists('debug.plots')) debug.plots<-'no'
if(debug.plots=='all'){plot(rbind(z,pg,0),bty='n'); points(z,pch='p')
lines(c(pg[,1],pg[1,1]),c(pg[,2],pg[1,2]))}
apg<-win(pg[,1],pg[,2])
apg[is.nan(apg)]<-0; a<-order(apg); apg<-apg[a]; pg<-pg[a,]
az<-win(z[,1],z[,2])
segm.no<-apply((outer(apg,az,'<')),2,sum)
segm.no<-ifelse(segm.no==0,n.pg,segm.no)
next.no<-1+(segm.no %% length(apg))
cuts<-cut.z.pg(z[,1],z[,2],pg[segm.no,1],pg[segm.no,2],
pg[next.no,1],pg[next.no,2])
cuts<-cbind(cuts[,1]+center[1],cuts[,2]+center[2])
return(cuts)
}
hdepth.of.points<-function(tp,n){
n.tp<-nrow(tp)
tphdepth<-rep(0,n.tp); dpi<-2*pi-0.000001
minusplus<-c(rep(-1,n),rep(1,n))
for(j in 1:n.tp) {
dx<-tp[j,1]-xy[,1]; dy<-tp[j,2]-xy[,2]
a<-win(dx,dy)+pi; h<-a<10;a<-a[h]; ident<-sum(!h)
init<-sum(a < pi); a.shift<-(a+pi) %% dpi
h<-cumsum(minusplus[order(c(a,a.shift))])
tphdepth[j]<-init+min(h)+1
}
tphdepth
}
expand.hull<-function(pg,k){
resolution<-floor(20*precision)
pg0<-xy[hdepth==1,]
pg0<-pg0[chull(pg0[,1],pg0[,2]),]
end.points<-find.cut.z.pg(pg,pg0,center=center,debug.plots=debug.plots)
lam<-((0:resolution)^1)/resolution^1
pg.new<-pg
for(i in 1:nrow(pg)){
tp<-cbind(pg[i,1]+lam*(end.points[i,1]-pg[i,1]),
pg[i,2]+lam*(end.points[i,2]-pg[i,2]))
hd.tp<-hdepth.of.points(tp,nrow(xy))
ind<-max(sum(hd.tp>=k),1)
if(indk &&
tp<-cbind(tp[ind,1]+lam*(tp[ind+1,1]-tp[ind,1]),
tp[ind,2]+lam*(tp[ind+1,2]-tp[ind,2]))
hd.tp<-hdepth.of.points(tp,nrow(xy))
ind<-max(sum(hd.tp>=k),1)
}
pg.new[i,]<-tp[ind,]
}
pg.new<-pg.new[chull(pg.new[,1],pg.new[,2]),]
pg.add<-0.5*(pg.new+rbind(pg.new[-1,],pg.new[1,]))
end.points<-find.cut.z.pg(pg,pg0,center=center)
for(i in 1:nrow(pg.add)){
tp<-cbind(pg.add[i,1]+lam*(end.points[i,1]-pg.add[i,1]),
pg.add[i,2]+lam*(end.points[i,2]-pg.add[i,2]))
hd.tp<-hdepth.of.points(tp,nrow(xy))
ind<-max(sum(hd.tp>=k),1)
if(indk &&
tp<-cbind(tp[ind,1]+lam*(tp[ind+1,1]-tp[ind,1]),
tp[ind,2]+lam*(tp[ind+1,2]-tp[ind,2]))
hd.tp<-hdepth.of.points(tp,nrow(xy))
ind<-max(sum(hd.tp>=k),1)
}
pg.add[i,]<-tp[ind,]
}
pg.new<-rbind(pg.new,pg.add)
pg.new<-pg.new[chull(pg.new[,1],pg.new[,2]),]
}
cut.p.sl.p.sl<-function(xy1,m1,xy2,m2){
sx<-(xy2[2]-m2*xy2[1]-xy1[2]+m1*xy1[1])/(m1-m2)
sy<-xy1[2]-m1*xy1[1]+m1*sx
if(!is.nan(sy)) return( c(sx,sy) )
if(abs(m1)==Inf) return( c(xy1[1],xy2[2]+m2*(xy1[1]-xy2[1])) )
if(abs(m2)==Inf) return( c(xy2[1],xy1[2]+m1*(xy2[1]-xy1[1])) )
}
pos.to.pg<-function(z,pg,reverse=FALSE){
if(reverse){
int.no<-apply(outer(pg[,1],z[,1],'>='),2,sum)
zy.on.pg<-pg[int.no,2]+pg[int.no,3]*(z[,1]-pg[int.no,1])
}else{
int.no<-apply(outer(pg[,1],z[,1],'<='),2,sum)
zy.on.pg<-pg[int.no,2]+pg[int.no,3]*(z[,1]-pg[int.no,1])
}
ifelse(z[,2]}
xydata<-if(missing(y)) x else cbind(x,y)
if(is.data.frame(xydata)) xydata<-as.matrix(xydata)
very.large.data.set<-nrow(xydata)>approx.limit
if(!exists('.Random.seed')) set.seed(13)
save.seed<-.Random.seed
if(very.large.data.set){
ind<-sample(seq(nrow(xydata)),size=approx.limit)
xy<-xydata[ind,]
} else xy<-xydata
n<-nrow(xy)
points.in.bag<-floor(n/2)
assign('.Random.seed',save.seed,env=.GlobalEnv)
if(verbose) cat('end of initialization')
prdata<-prcomp(xydata)
is.one.dim<-(min(prdata[[1]])/max(prdata[[1]]))<0.0001
if(is.one.dim){
if(verbose) cat('data set one dimensional')
center<-colMeans(xydata)
res<-list(xy=xy,xydata=xydata,prdata=prdata,is.one.dim=is.one.dim,center=center)
class(res)<-'bagplot'
return(res)
}
if(verbose) cat('data not linear')
dx<-(outer(xy[,1],xy[,1],'-'))
dy<-(outer(xy[,2],xy[,2],'-'))
alpha<-atan2(y=dy,x=dx); diag(alpha)<-1200
for(j in 1:n) alpha[,j]<-sort(alpha[,j])
alpha<-alpha[-n,] ; m<-n-1
if(debug.plots=='all'){
plot(xy,bty='n'); xdelta<-abs(diff(range(xy[,1]))); dx<-xdelta*.3
for(j in 1:n) {
p<-xy[j,]; dy<-dx*tan(alpha[,j])
segments(p[1]-dx,p[2]-dy,p[1]+dx,p[2]+dy,col=j)
text(p[1]-xdelta*.02,p[2],j,col=j)
}
}
if(verbose) print('end of computation of angles')
hdepth<-rep(0,n); dpi<-2*pi-0.000001
minusplus<-c(rep(-1,m),rep(1,m))
for(j in 1:n) {
a<-alpha[,j]+pi; h<-a<10; a<-a[h]; init<-sum(a < pi) # hallo
a.shift<-(a+pi) %% dpi
h<-cumsum(minusplus[order(c(a,a.shift))])
hdepth[j]<-init+min(h)+1 #  or do we have to count identical points?:
}
if(verbose){print('end of computation of hdepth:'); print(hdepth)}
if(debug.plots=='all'){
plot(xy,bty='n')
xdelta<-abs(diff(range(xy[,1]))); dx<-xdelta*.1
for(j in 1:n) {
a<-alpha[,j]+pi; a<-a[a<10]; init<-sum(a < pi)
a.shift<-(a+pi) %% dpi
h<-cumsum(minusplus[ao<-(order(c(a,a.shift)))])
no<-which((init+min(h)) == (init+h))[1]
p<-xy[j,]; dy<-dx*tan(alpha[,j])
segments(p[1]-dx,p[2]-dy,p[1]+dx,p[2]+dy,col=j,lty=3)
dy<-dx*tan(c(sort(a),sort(a))[no])
segments(p[1]-5*dx,p[2]-5*dy,p[1]+5*dx,p[2]+5*dy,col='black')
text(p[1]-xdelta*.02,p[2],hdepth[j],col=1,cex=2.5)
}
}
hd.table<-table(sort(hdepth))
d.k<-cbind(dk=rev(cumsum(rev(hd.table))),
k =as.numeric(names(hd.table)))
k.1<-sum(points.in.bagif(nrow(d.k)>1){
k<-d.k[k.1+1,2]
} else {
k<-d.k[k.1,2]
}
if(verbose){cat('counts of members of dk:'); print(hd.table)}
if(verbose){cat('end of computation of k, k=',k)}
center<-apply(xy[which(hdepth==max(hdepth)),,drop=FALSE],2,mean)
hull.center<-NULL
if(102){
n.p<-floor(c(32,16,8)[1+(n>50)+(n>200)]*precision)
cands<-xy[rev(order(hdepth))[1:6],]
cands<-cands[chull(cands[,1],cands[,2]),]; n.c<-nrow(cands)
xyextr<-rbind(apply(cands,2,min),apply(cands,2,max))
h1<-seq(xyextr[1,1],xyextr[2,1],length=n.p)
h2<-seq(xyextr[1,2],xyextr[2,2],length=n.p)
tp<-cbind(matrix(h1,n.p,n.p)[1:n.p^2],
matrix(h2,n.p,n.p,TRUE)[1:n.p^2])
tphdepth<-hdepth.of.points(tp,n)
hull.center<-tp[which(tphdepth>=(max(tphdepth))),,drop=FALSE]
center<-apply(hull.center,2,mean)
cands<-hull.center[chull(hull.center[,1],hull.center[,2]),,drop=F]
xyextr<-rbind(apply(cands,2,min),apply(cands,2,max))
xydel<-(xyextr[2,]-xyextr[1,])/n.p
xyextr<-rbind(xyextr[1,]-xydel,xyextr[2,]+xydel)
h1<-seq(xyextr[1,1],xyextr[2,1],length=n.p)
h2<-seq(xyextr[1,2],xyextr[2,2],length=n.p)
tp<-cbind(matrix(h1,n.p,n.p)[1:n.p^2],
matrix(h2,n.p,n.p,TRUE)[1:n.p^2])
tphdepth<-hdepth.of.points(tp,n)
hull.center<-tp[which(tphdepth>=max(tphdepth)),,drop=FALSE]
center<-apply(hull.center,2,mean)
hull.center<-hull.center[chull(hull.center[,1],hull.center[,2]),]
if(verbose){cat('hull.center',hull.center); print(table(tphdepth)) }
}
if(verbose) cat('center depth:',hdepth.of.points(rbind(center),n))
if(verbose){print('end of computation of center'); print(center)}
if(dkmethod==1){
xyi<-xy[hdepth>=k,,drop=FALSE]
pdk<-xyi[chull(xyi[,1],xyi[,2]),,drop=FALSE]
xyo<-xy[hdepth>=(k-1),,drop=FALSE]
pdk.1<-xyo[chull(xyo[,1],xyo[,2]),,drop=FALSE]
if(verbose)cat('hull computed:')
if(debug.plots=='all'){
plot(xy,bty='n')
h<-rbind(pdk,pdk[1,]); lines(h,col='red',lty=2)
h<-rbind(pdk.1,pdk.1[1,]);lines(h,col='blue',lty=3)
points(center[1],center[2],pch=8,col='red')
}
exp.dk<-expand.hull(pdk,k)
exp.dk.1<-expand.hull(exp.dk,k-1) # pdk.1,k-1,20)
}else{
num<-floor(c(417,351,171,85,67,43)[sum(n>c(1,50,100,150,200,250))]*precision)
num.h<-floor(num/2); angles<-seq(0,pi,length=num.h)
ang<-tan(pi/2-angles)
xym<-apply(xy,2,mean); xysd<-apply(xy,2,sd)
xyxy<-cbind((xy[,1]-xym[1])/xysd[1],(xy[,2]-xym[2])/xysd[2])
kkk<-k
ia<-1; a<-angles[ia]; xyt<-xyxy%*%c(cos(a),-sin(a)); xyto<-order(xyt)
ind.k <-xyto[kkk]; cutp<-c(xyxy[ind.k,1],-10)
dxy<-diff(range(xyxy))
pg<-rbind(c(cutp[1],-dxy,Inf),c(cutp[1],dxy,NA))
ind.kk<-xyto[n+1-kkk]; cutpl<-c(xyxy[ind.kk,1],10)
pgl<-rbind(c(cutpl[1],dxy,Inf),c(cutpl[1],-dxy,NA))
if(debug.plots=='all'){ plot(xyxy,type='p',bty='n')
}
for(ia in seq(angles)[-1]){
a<-angles[ia]; angtan<-ang[ia]; xyt<-xyxy%*%c(cos(a),-sin(a)); xyto<-order(xyt)
ind.k <-xyto[kkk]; ind.kk<-xyto[n+1-kkk]; pnew<-xyxy[ind.k,]; pnewl<-xyxy[ind.kk,]
if(debug.plots=='all') points(pnew[1],pnew[2],col='red')
if(abs(angtan)>1e10){  ###  cat('y=c case')
pg.no<-sum(pg[,1]cutp<-c(pnew[1],pg[pg.no,2]+pg[pg.no,3]*(pnew[1]-pg[pg.no,1]))
pg.nol<-sum(pgl[,1]>=pnewl[1])
cutpl<-c(pnewl[1],pgl[pg.nol,2]+pgl[pg.nol,3]*(pnewl[1]-pgl[pg.nol,1]))
}else{    ### cat('normal case')
pg.inter<-pg[,2]-angtan*pg[,1]; pnew.inter<-pnew[2]-angtan*pnew[1]
pg.no<-sum(pg.intercutp<-cut.p.sl.p.sl(pnew,ang[ia],pg[pg.no,1:2],pg[pg.no,3])
pg.interl<-pgl[,2]-angtan*pgl[,1]; pnew.interl<-pnewl[2]-angtan*pnewl[1]
pg.nol<-sum(pg.interl>pnew.interl)
cutpl<-cut.p.sl.p.sl(pnewl,angtan,pgl[pg.nol,1:2],pgl[pg.nol,3])
}
pg<-rbind(pg[1:pg.no,],c(cutp,angtan),c(cutp[1]+dxy, cutp[2]+angtan*dxy,NA))
pgl<-rbind(pgl[1:pg.nol,],c(cutpl,angtan),c(cutpl[1]-dxy, cutpl[2]-angtan*dxy,NA))
if(debug.plots=='all'){
points(pnew[1],pnew[2],col='red')
hx<-xyxy[ind.k,c(1,1)]; hy<-xyxy[ind.k,c(2,2)]
segments(hx,hy,c(10,-10),hy+ang[ia]*(c(10,-10)-hx),lty=2)
points(cutpl[1],cutpl[2],col='red')
hx<-xyxy[ind.kk,c(1,1)]; hy<-xyxy[ind.kk,c(2,2)]
segments(hx,hy,c(10,-10),hy+ang[ia]*(c(10,-10)-hx),lty=2)
}
}
pg<-pg[-nrow(pg),][-1,,drop=F]; pgl<-pgl[-nrow(pgl),][-1,,drop=FALSE]
indl<-pos.to.pg(pgl,pg); indu<-pos.to.pg(pg,pgl,TRUE)
npg<-nrow(pg); npgl<-nrow(pgl)
rnuml<-rnumu<-lnuml<-lnumu<-0; sl<-pg[1,1:2]; sr<-pgl[1,1:2]
if(indl[1]=='higher'&indu[npg]=='lower'){
rnuml<-which(indl=='lower')[1]-1; xyl<-pgl[rnuml,] #
rnumu<-which(rev(indu=='higher'))[1]; xyu<-pg[npg+1-rnumu,] #
sr<-cut.p.sl.p.sl(xyl[1:2],xyl[3],xyu[1:2],xyu[3])
}
if(indl[npgl]=='higher'&indu[1]=='lower'){
lnuml<-which(rev(indl=='lower'))[1]; xyl<-pgl[npgl+1-lnuml,] #
lnumu<-which(indu=='higher')[1]-1; xyu<-pg[lnumu,] #?
sl<-cut.p.sl.p.sl(xyl[1:2],xyl[3],xyu[1:2],xyu[3])
}
pgl<-pgl[(rnuml+1):(npgl-lnuml),1:2,drop=FALSE]
pg <-pg [(lnumu+1):(npg -rnumu),1:2,drop=FALSE]
pg<-rbind(pg,sr,pgl,sl)
pg<-pg[chull(pg[,1],pg[,2]),]
if(debug.plots=='all') lines(rbind(pg,pg[1,]),col='red')
exp.dk<-cbind(pg[,1]*xysd[1]+xym[1],pg[,2]*xysd[2]+xym[2])
if(kkk>1) kkk<-kkk-1
ia<-1; a<-angles[ia]; xyt<-xyxy%*%c(cos(a),-sin(a)); xyto<-order(xyt)
ind.k <-xyto[kkk]; cutp<-c(xyxy[ind.k,1],-10)
dxy<-diff(range(xyxy))
pg<-rbind(c(cutp[1],-dxy,Inf),c(cutp[1],dxy,NA))
ind.kk<-xyto[n+1-kkk]; cutpl<-c(xyxy[ind.kk,1],10)
pgl<-rbind(c(cutpl[1],dxy,Inf),c(cutpl[1],-dxy,NA))
if(debug.plots=='all'){ plot(xyxy,type='p',bty='n')
}
for(ia in seq(angles)[-1]){
a<-angles[ia]; angtan<-ang[ia]; xyt<-xyxy%*%c(cos(a),-sin(a)); xyto<-order(xyt)
ind.k <-xyto[kkk]; ind.kk<-xyto[n+1-kkk]; pnew<-xyxy[ind.k,]; pnewl<-xyxy[ind.kk,]
if(debug.plots=='all') points(pnew[1],pnew[2],col='red')
if(abs(angtan)>1e10){  ###  cat('y=c case')
pg.no<-sum(pg[,1]cutp<-c(pnew[1],pg[pg.no,2]+pg[pg.no,3]*(pnew[1]-pg[pg.no,1]))
pg.nol<-sum(pgl[,1]>=pnewl[1])
cutpl<-c(pnewl[1],pgl[pg.nol,2]+pgl[pg.nol,3]*(pnewl[1]-pgl[pg.nol,1]))
}else{    ### cat('normal case')
pg.inter<-pg[,2]-angtan*pg[,1]; pnew.inter<-pnew[2]-angtan*pnew[1]
pg.no<-sum(pg.intercutp<-cut.p.sl.p.sl(pnew,ang[ia],pg[pg.no,1:2],pg[pg.no,3])
pg.interl<-pgl[,2]-angtan*pgl[,1]; pnew.interl<-pnewl[2]-angtan*pnewl[1]
pg.nol<-sum(pg.interl>pnew.interl)
cutpl<-cut.p.sl.p.sl(pnewl,angtan,pgl[pg.nol,1:2],pgl[pg.nol,3])
}
pg<-rbind(pg[1:pg.no,],c(cutp,angtan),c(cutp[1]+dxy, cutp[2]+angtan*dxy,NA))
pgl<-rbind(pgl[1:pg.nol,],c(cutpl,angtan),c(cutpl[1]-dxy, cutpl[2]-angtan*dxy,NA))
if(debug.plots=='all'){
points(pnew[1],pnew[2],col='red')
hx<-xyxy[ind.k,c(1,1)]; hy<-xyxy[ind.k,c(2,2)]
segments(hx,hy,c(10,-10),hy+ang[ia]*(c(10,-10)-hx),lty=2)
points(cutpl[1],cutpl[2],col='red')
hx<-xyxy[ind.kk,c(1,1)]; hy<-xyxy[ind.kk,c(2,2)]
segments(hx,hy,c(10,-10),hy+ang[ia]*(c(10,-10)-hx),lty=2)
}
}
pg<-pg[-nrow(pg),][-1,,drop=F]; pgl<-pgl[-nrow(pgl),][-1,,drop=FALSE]
indl<-pos.to.pg(pgl,pg); indu<-pos.to.pg(pg,pgl,TRUE)
npg<-nrow(pg); npgl<-nrow(pgl)
rnuml<-rnumu<-lnuml<-lnumu<-0; sl<-pg[1,1:2]; sr<-pgl[1,1:2]
if(indl[1]=='higher'&indu[npg]=='lower'){
rnuml<-which(indl=='lower')[1]-1; xyl<-pgl[rnuml,] #
rnumu<-which(rev(indu=='higher'))[1]; xyu<-pg[npg+1-rnumu,] #
sr<-cut.p.sl.p.sl(xyl[1:2],xyl[3],xyu[1:2],xyu[3])
}
if(indl[npgl]=='higher'&indu[1]=='lower'){
lnuml<-which(rev(indl=='lower'))[1]; xyl<-pgl[npgl+1-lnuml,] #
lnumu<-which(indu=='higher')[1]-1; xyu<-pg[lnumu,] #?
sl<-cut.p.sl.p.sl(xyl[1:2],xyl[3],xyu[1:2],xyu[3])
}
pgl<-pgl[(rnuml+1):(npgl-lnuml),1:2,drop=FALSE]
pg <-pg [(lnumu+1):(npg -rnumu),1:2,drop=FALSE]
pg<-rbind(pg,sr,pgl,sl)
pg<-pg[chull(pg[,1],pg[,2]),]
if(debug.plots=='all') lines(rbind(pg,pg[1,]),col='red')
exp.dk.1<-cbind(pg[,1]*xysd[1]+xym[1],pg[,2]*xysd[2]+xym[2])
}
lambda<-if(nrow(d.k)==1) 0.5 else
(n/2-d.k[k.1+1,1])/(d.k[k.1,1]-d.k[k.1+1,1])
if(verbose) cat('lambda',lambda)
cut.on.pdk.1<-find.cut.z.pg(exp.dk,  exp.dk.1,center=center)
cut.on.pdk  <-find.cut.z.pg(exp.dk.1,exp.dk,  center=center)
h1<-(1-lambda)*exp.dk+lambda*cut.on.pdk.1
h2<-(1-lambda)*cut.on.pdk+lambda*exp.dk.1
h<-rbind(h1,h2); hull.bag<-h[chull(h[,1],h[,2]),]
if(verbose)cat('bag completed:') #if(verbose)print(hull.bag)
if(debug.plots=='all'){   lines(hull.bag,col='red') }
hull.loop<-cbind(hull.bag[,1]-center[1],hull.bag[,2]-center[2])
hull.loop<-factor*hull.loop
hull.loop<-cbind(hull.loop[,1]+center[1],hull.loop[,2]+center[2])
if(verbose) cat('loop computed')
if(!very.large.data.set){
pxy.bag    <-xydata[hdepth>= k   ,,drop=FALSE]
pkt.cand   <-xydata[hdepth==(k-1),,drop=FALSE]
pkt.not.bag<-xydata[hdepth< (k-1),,drop=FALSE]
if(length(pkt.cand)>0){
outside<-out.of.polygon(pkt.cand,hull.bag)
if(sum(!outside)>0)
pxy.bag    <-rbind(pxy.bag,     pkt.cand[!outside,])
if(sum( outside)>0)
pkt.not.bag<-rbind(pkt.not.bag, pkt.cand[ outside,])
}
}else {
extr<-out.of.polygon(xydata,hull.bag)
pxy.bag    <-xydata[!extr,]
pkt.not.bag<-xydata[extr,,drop=FALSE]
}
if(length(pkt.not.bag)>0){
extr<-out.of.polygon(pkt.not.bag,hull.loop)
pxy.outlier<-pkt.not.bag[extr,,drop=FALSE]
if(0==length(pxy.outlier)) pxy.outlier<-NULL
pxy.outer<-pkt.not.bag[!extr,,drop=FALSE]
}else{
pxy.outer<-pxy.outlier<-NULL
}
if(verbose) cat('points of bag, outer points and outlier identified')
hull.loop<-rbind(pxy.outer,hull.bag)
hull.loop<-hull.loop[chull(hull.loop[,1],hull.loop[,2]),]
if(verbose) cat('end of computation of loop')
assign('.Random.seed',save.seed,env=.GlobalEnv)
res<-list(
center=center,
pxy.bag=pxy.bag,
pxy.outer=if(length(pxy.outer)>0) pxy.outer else NULL,
pxy.outlier=if(length(pxy.outlier)>0) pxy.outlier else NULL,
hull.center=hull.center,
hull.bag=hull.bag,
hull.loop=hull.loop,
hdepths=hdepth,
is.one.dim=is.one.dim,
prdata=prdata,
xy=xy,xydata=xydata
)
if(verbose) res<-c(res,list(exp.dk=exp.dk,exp.dk.1=exp.dk.1,hdepth=hdepth))
class(res)<-'bagplot'
return(res)
}
plot.bagplot<-function(bagplot.obj,
show.outlier=TRUE,# if TRUE outlier are shown
show.whiskers=TRUE, # if TRUE whiskers are shown
show.looppoints=TRUE, # if TRUE points in loop are shown
show.bagpoints=TRUE, # if TRUE points in bag are shown
show.loophull=TRUE, # if TRUE loop is shown
show.baghull=TRUE, # if TRUE bag is shown
add=FALSE, # if TRUE graphical elements are added to actual plot
pch=16,cex=.4,..., # to define further parameters of plot
verbose=FALSE # tools for debugging
){
win<-function(dx,dy){  atan2(y=dy,x=dx) }
cut.z.pg<-function(zx,zy,p1x,p1y,p2x,p2y){
a2<-(p2y-p1y)/(p2x-p1x); a1<-zy/zx
sx<-(p1y-a2*p1x)/(a1-a2); sy<-a1*sx
sxy<-cbind(sx,sy)
h<-any(is.nan(sxy))||any(is.na(sxy))||any(Inf==abs(sxy))
if(h){
if(!exists('verbose')) verbose<-FALSE
if(verbose) cat('special')
h<-0==(a1-a2) & sign(zx)==sign(p1x)
sx<-ifelse(h,p1x,sx); sy<-ifelse(h,p1y,sy)
h<-0==(a1-a2) & sign(zx)!=sign(p1x)
sx<-ifelse(h,p2x,sx); sy<-ifelse(h,p2y,sy)
h<-p1x==p2x & zx!=p1x & p1x!=0
sx<-ifelse(h,p1x,sx); sy<-ifelse(h,zy*p1x/zx,sy)
h<-p1x==p2x & zx!=p1x & p1x==0
sx<-ifelse(h,p1x,sx); sy<-ifelse(h,0,sy)
h<-p1x==p2x & zx==p1x & p1x==0 & sign(zy)==sign(p1y)
sx<-ifelse(h,p1x,sx); sy<-ifelse(h,p1y,sy)
h<-p1x==p2x & zx==p1x & p1x==0 & sign(zy)!=sign(p1y)
sx<-ifelse(h,p1x,sx); sy<-ifelse(h,p2y,sy)
h<-zx==p1x & zy==p1y; sx<-ifelse(h,p1x,sx); sy<-ifelse(h,p1y,sy)
h<-zx==p2x & zy==p2y; sx<-ifelse(h,p2x,sx); sy<-ifelse(h,p2y,sy)
h<-zx==0 & zy==0; sx<-ifelse(h,0,sx); sy<-ifelse(h,0,sy)
sxy<-cbind(sx,sy)
} # end of special cases
if(!exists('debug.plots')) debug.plots<-'no'
if(debug.plots=='all'){
segments(sxy[,1],sxy[,2],zx,zy,col='red')
segments(0,0,sxy[,1],sxy[,2],type='l',col='green',lty=2)
points(sxy,col='red')
}
return(sxy)
}
find.cut.z.pg<-function(z,pg,center=c(0,0),debug.plots='no'){
if(!is.matrix(z)) z<-rbind(z)
if(1==nrow(pg)) return(matrix(center,nrow(z),2,TRUE))
n.pg<-nrow(pg); n.z<-nrow(z)
z<-cbind(z[,1]-center[1],z[,2]-center[2])
pgo<-pg; pg<-cbind(pg[,1]-center[1],pg[,2]-center[2])
if(!exists('debug.plots')) debug.plots<-'no'
if(debug.plots=='all'){plot(rbind(z,pg,0),bty='n'); points(z,pch='p')
lines(c(pg[,1],pg[1,1]),c(pg[,2],pg[1,2]))}
apg<-win(pg[,1],pg[,2])
apg[is.nan(apg)]<-0; a<-order(apg); apg<-apg[a]; pg<-pg[a,]
az<-win(z[,1],z[,2])
segm.no<-apply((outer(apg,az,'<')),2,sum)
segm.no<-ifelse(segm.no==0,n.pg,segm.no)
next.no<-1+(segm.no %% length(apg))
cuts<-cut.z.pg(z[,1],z[,2],pg[segm.no,1],pg[segm.no,2],
pg[next.no,1],pg[next.no,2])
cuts<-cbind(cuts[,1]+center[1],cuts[,2]+center[2])
return(cuts)
}
for(i in seq(along=bagplot.obj))
eval(parse(text=paste(names(bagplot.obj)[i],'<-bagplot.obj[[',i,']]')))
if(is.one.dim){
if(verbose) cat('data set one dimensional')
prdata<-prdata[[2]];
trdata<-xydata%*%prdata; ytr<-mean(trdata[,2])
boxplotres<-boxplot(trdata[,1],plot=FALSE)
dy<-0.1*diff(range(stats<-boxplotres$stats))
dy<-0.05*mean(c(diff(range(xydata[,1])),
diff(range(xydata[,2]))))
segtr<-rbind(cbind(stats[2:4],ytr-dy,stats[2:4],ytr+dy),
cbind(stats[c(2,2)],ytr+c(dy,-dy),
stats[c(4,4)],ytr+c(dy,-dy)),
cbind(stats[c(2,4)],ytr,stats[c(1,5)],ytr))
segm<-cbind(segtr[,1:2]%*%t(prdata),
segtr[,3:4]%*%t(prdata))
if(!add) plot(xydata,type='n',bty='n',pch=16,cex=.2,...)
extr<-c(min(segm[6,3],segm[7,3]),max(segm[6,3],segm[7,3]))
extr<-extr+c(-1,1)*0.000001*diff(extr)
xydata<-xydata[xydata[,1]xydata[,1]>extr[2],,drop=FALSE]
if(0segments(segm[,1],segm[,2],segm[,3],segm[,4],)
return('one dimensional boxplot plottet')
}
if(!add) plot(xydata,type='n',pch=pch,cex=cex,bty='n',...)
if(verbose) text(xy[,1],xy[,2],paste(as.character(hdepth)),cex=2)
if(show.loophull){ # fill loop
h<-rbind(hull.loop,hull.loop[1,]); lines(h[,1],h[,2],lty=1)
polygon(hull.loop[,1],hull.loop[,2],col='#aaccff')
}
if(show.looppoints && length(pxy.outer)>0){ # points in loop
points(pxy.outer[,1],pxy.outer[,2],col='#3355ff',pch=pch,cex=cex)
}
if(show.baghull){ # fill bag
h<-rbind(hull.bag,hull.bag[1,]); lines(h[,1],h[,2],lty=1)
polygon(hull.bag[,1],hull.bag[,2],col='#7799ff')
}
if(show.bagpoints && length(pxy.bag)>0){ # points in bag
points(pxy.bag[,1],pxy.bag[,2],col='#000088',pch=pch,cex=cex)
}
if(show.whiskers && length(pxy.outer)>0){
debug.plots<-'not'
pkt.cut<-find.cut.z.pg(pxy.outer,hull.bag,center=center)
segments(pxy.outer[,1],pxy.outer[,2],pkt.cut[,1],pkt.cut[,2],col='red')
}
if(show.outlier && length(pxy.outlier)>0){ # points in loop
points(pxy.outlier[,1],pxy.outlier[,2],col='red',pch=pch,cex=cex)
}
if(exists('hull.center')&&length(hull.center)>2){
h<-rbind(hull.center,hull.center[1,]); lines(h[,1],h[,2],lty=1)
polygon(hull.center[,1],hull.center[,2],col='orange')
}
points(center[1],center[2],pch=8,col='red')
if(verbose){
h<-rbind(exp.dk,exp.dk[1,]); lines(h,col='blue',lty=2)
h<-rbind(exp.dk.1,exp.dk.1[1,]); lines(h,col='black',lty=2)
if(exists('tphdepth'))
text(tp[,1],tp[,2],as.character(tphdepth),col='green')
text(xy[,1],xy[,2],paste(as.character(hdepth)),cex=2)
points(center[1],center[2],pch=8,col='red')
}
'bagplot plottet'
}
bagplot<-function(x,y,
factor=3, # expanding factor for bag to get the loop
approx.limit=300, # limit
show.outlier=TRUE,# if TRUE outlier are shown
show.whiskers=TRUE, # if TRUE whiskers are shown
show.looppoints=TRUE, # if TRUE points in loop are shown
show.bagpoints=TRUE, # if TRUE points in bag are shown
show.loophull=TRUE, # if TRUE loop is shown
show.baghull=TRUE, # if TRUE bag is shown
create.plot=TRUE, # if TRUE a plot is created
add=FALSE, # if TRUE graphical elements are added to actual plot
pch=16,cex=.4,..., # to define further parameters of plot
dkmethod=2, # in 1:2; there are two methods for approximating the bag
precision=1, # controls precisionn of computation
verbose=FALSE,debug.plots='' # tools for debugging
){
bo<-compute.bagplot(x=x,y=y,factor=factor,approx.limit=approx.limit,
dkmethod=dkmethod,precision=precision,
verbose=verbose,debug.plots=debug.plots)
if(create.plot){
plot(bo,
show.outlier=show.outlier,
show.whiskers=show.whiskers,
show.looppoints=show.looppoints,
show.bagpoints=show.bagpoints,
show.loophull=show.loophull,
show.baghull=show.baghull,
add=add,pch=pch,cex=cex,...,
verbose=verbose
)
}
}
bitmap(file='test1.png')
bagplot(x=x, y=y, verbose=F, factor=par1, show.outlier=par2, show.whiskers=par3, show.baghull=T, dkmethod=2, show.loophull=T, precision=1, xlab=xlab, ylab=ylab, main=main)
box()
dev.off()