Send output to:
Browser Blue - Charts White
Browser Black/White
CSV
Data X:
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
Data Y:
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
Sample Range:
(leave blank to include all observations)
From:
To:
Factor (defining the loop)
Show outliers
TRUE
TRUE
FALSE
Show whiskers
TRUE
TRUE
FALSE
Chart options
Title:
Label y-axis:
Label x-axis:
R Code
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]<-pi<max(diff(alpha)) | pi<(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(ind<length(hd.tp)){ # hd.tp[ind]>k && 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(ind<length(hd.tp)){ # hd.tp[ind]>k && 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]<zy.on.pg, 'lower','higher') } 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.bag<d.k[,1]) if(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(10<nrow(xy)&&length(hd.table)>2){ 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]<pnew[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.inter<pnew.inter) cutp<-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]<pnew[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.inter<pnew.inter) cutp<-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]<extr[1] | xydata[,1]>extr[2],,drop=FALSE] if(0<nrow(xydata))points(xydata[,1],xydata[,2],pch=pch,cex=cex) segments(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()
Compute
Summary of computational transaction
Raw Input
view raw input (R code)
Raw Output
view raw output of R engine
Computing time
0 seconds
R Server
Big Analytics Cloud Computing Center
Click here to blog (archive) this computation