# Copyright (C) 2014 Setsuo Takato, KETCindy Japan project team # #This program is free software: you can redistribute it and/or modify # it under the terms of the GNU General Public License as published by # the Free Software Foundation; either version 3 of the License, or # (at your option) any later version. # # This program is distributed in the hope that it will be useful, # but WITHOUT ANY WARRANTY; without even the implied warranty of # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the # GNU General Public License for more details. # # You should have received a copy of the GNU General Public License # along with this program. If not, see ######################################### # source("/Rfiles/ketpic5_2_3.r") ThisVersion<- "KeTpic for R v5_2_3(17.10.08)" # 2017.10.11 # Drwpt debugged (Flattenlist ) # 2017.10.08 # Bezier debugged ( Num ) # 2017.10.07 # ReadOutData debugged ( for null data ) # 2017.10.06 # Deqdata, Deqplot added # Connectseg remade(bug) # 2017.09.30 # Bezierpt, Bezier added # 2017.09.29 # Ptcrv debugged # 2017.09.28 # Openfile changed # 2017.09.24 # Circledata debugged # Kyoukai changed (Eps) # Shade updated # 2017.09.22 # Setcolor changed # Plotdata,Paramplot,Spacecurve changed (N-1 -> N) # 2017.09.21 # Shade changed (Sci 17.01.09) # 2017.09.17 # Ovaldata,Assignadd changed # Dist added # Cicledata changed # Bowdata debugged (Circledata,etc) # 2015.11.05 # WriteOutData changed # 2015.10.29 # WriteOutData changed ( endmark //// ) # 2015.10.24 # ReadOutData changed ( in case of listlength=1 ) # 2014.12.23 # ReadOutData added # 2014.12.17 # WriteOutData added # 2014.0905 # Unscaling debugged MARKLENI => MARKLEN # 2014.03.31 # PhHiddenData added # 2014.03.30 # Facesdata changed ( for Hiddendata ) # 2014.03.23 # MARKLEN separated, Rotate3data debugged # 2013.12.19 # Openfile, Closefile, Bowname, Bownamerot # 2013.11.13 # Arrowhead, Arrowheaddata # 2013.08.07 # Cancoordpara added # 2013.08.07 # Integrate added # 2013.05.20 # Openfile changed # 2013.05.03 # Tabledata, Pointdata changed # Dividetable, Partframe added # 2013.02.10 # Ketinit added # 2012.01.07 # Arrowline, Arrowhead ( Cut implemented ) # 2011.12.18 # Framedata ( compliant for list ) # 2011.12.12 # Skeletonparadata... ( Flattellist used) # 2011.11.27 # drwboxframe # 2011.11.07 # metacommands added # 2011.11.02 # Joingraphics ( for list structure ) # 2011.08.24 # Setcolor ( c(1,0,0,0.5) etc ) # Rotate3data ( Point is available ) # 2011.07.19 # Drwline, Letter, Expr # Drwboxplot( etc ) min,max => outliners # Drwline ( unfinished in the case of "integer" ) # 2011.06.25 # joincrvs debugged # synchro with ketpict2e # 2011.06.01 # Bowdata debugged #2011.05.28 # Ratiocmyk, Setcolor ( new ) #2011.04.28 # Htickmark, Vtickmark debugged #2011.03.08 # Drwboxframe debugged # Putrow, Putrowexpr debugged (Dpos ) #2011.03.02 # Tabledata ( index of hline ), PutcoL, PutcoLexpr ( "r",...) debugged # Texcom changed ( // => backslash ) #2011.01.07 # Dividegraphics, Splinedat are changed significantly # Readtextdata is changed #2011.01.04 # Derivative, Integrate are added #2010.12.07 # Translatedata, Scaledata, Reflectdata changed ( efficient for vector ) # Rotatedata changed ( deg : logical ) # HIstplotdata, Drwhistplot ( type => freq , fpplot (added) ) # 2010.12.04 # WindispT changed ( tickmark ) # Lineplot changed ( mag=> length ) # Plotdata debugged ( 'E=fun', 'D=') # Enclosing changed (return PD) # 2010.12.02 # WindispT changed # Makecurves debugged # 2010.11.27 # Pointdata changed ( efficient for matrix and data.frame ) # WindispT # Setwindow ( decide from data ) # Assign debugged ( strsplit => gsub(fixed=T)) # 2010.11.20 # Flattenlist, WindispT # Splinedata changed( efficient for data.frame ) #2010.08.19 ( Maybe not finished ) # Stripblanks # Fullformfunc, Sf3data #2010.08.17 # Phparadata, Phpersdata, Phspersdata, Phsparadata # Facesdata, MakeveLfaceL, Menkakusi2 # Rotate3data # Skeletonpersdata, Skeletonpers3data, Makeskeletonpersdata # Embed #2010.08.16 # Spacecurve changed # CameracoordCurve, Partcrv3, Projpers, CameraCurve, # Perspt, Xyzaxpersname, Invperspt, Zparapt, Zperspt # 2010.08.15 # Phcutoffdata added # 2010.08.13 # Phcutdata, Spacecurve debugged # Setangle changed # 2010.08.09 # Spacecurve # Rotate3data, Rotate3pt # Phcutdata # 2010.08.08 # Implementing 3d # Initangle, Setangle, Setpers, SetstereoL, SetstereoR # Mixlength # Spaceline, Projpara, ProjCurve, Parapt # Xyzax3data, Xyzaxparaname # Cancoordpers, Invparapt, ProjcoordCurve # Skeletonparadata, Skeletonpara3data, Makeskeletondata, Kukannozoki # 2010.07.25 # Rotatedata changed # Drwline changed (list of list) # 2010.04.09 # Stat package added # 2010.04.02 # Putcolexpr, Putrowexpr # 2010.04.02 # Windisp, Op changed # Execmd added # Texnewcmd, Texrenewcmd, Texend, # Texctr, Texnewctr, Texsetctr # Kyoukai debugged # 2010.01.20 # Partcrv, Makeshasen : debugged # 2010.01.23 # Ovaldata, Ovalbox added # 2010.01.27 # Readtextdata changed # Putrow, PutcoL debugged ( Putcol is OK) # 2010.01.31 # Writetextdata added # 2010.02.12 # Texvalctr, Texthectr added # 2010.02.22 # Execmd changed # 2010.02.23 # Op, Windisp changed # 2010.02.24 # Execmd changed # 2010.03.07 # Dotfilldata (Kosa>1) # 2010.03.21 # Mixjoin # Koutenlist (bug) # 2010.03.24 # Arrowhead ( bug in the case of "l" ) # 2010.03.28 # Tabledata # Diagcelldata ( New ) # 2010.03.30 # Tabledata ########################################### XMIN<- -5 XMAX<- 5 YMIN<- -5 ; YMAX<- 5 ZIKU<- "line" ARROWSIZE<- 1 XNAME<- "$x$" XPOS<- "e" YNAME<- "$y$" YPOS<- "n" ONAME<- "O" OPOS<- "sw" ULEN<- "1cm" MilliIn<- 1/2.54*1000 PenThick<- round(MilliIn*0.02) PenThickInit<- PenThick TenSizeInit<<- 0.02*2 #17.10.07 TenSize<- TenSizeInit Wfile<-"" MEMORI<- 0.05 MEMORIInit<- MEMORI MEMORINow<- MEMORI MARKLEN<- 0.05 MARKLENInit<- MARKLEN MARKLENNow<- MARKLEN GENTEN<- c(0,0) YaSize<- 1 YaAngle<- 18 YaPosition<- 1 YaThick<- 1 YaStyle<- "tf" PHI<- 30*pi/180 THETA<- 60*pi/180 FocusPoint<- c(0,0,0) EyePoint<- c(5,5,5) ASSIGNLIST<- list("`","'") SCALEX<- 1 SCALEY<- 1 LOGX<- 0 LOGY<- 0 TEXFORLEVEL<- 0 TEXFORLAST<- list() ####################### Ketinit<- function(){ XMIN<<- -5 XMAX<<- 5 YMIN<<- -5 ; YMAX<<- 5 ZIKU<<- "line" ARROWSIZE<<- 1 XNAME<<- "$x$" XPOS<<- "e" YNAME<<- "$y$" YPOS<<- "n" ONAME<<- "O" OPOS<<- "sw" ULEN<<- "1cm" MilliIn<<- 1/2.54*1000 PenThick<<- round(MilliIn*0.02) PenThickInit<<- PenThick TenSizeInit<<- 0.02*2 #17.10.07 TenSize<<- TenSizeInit Wfile<<-"" MEMORI<<- 0.05 MEMORIInit<<- MEMORI MEMORINow<<- MEMORI MARKLEN<<- 0.05 MARKLENInit<<- MARKLEN MARKLENNow<<- MARKLEN GENTEN<<- c(0,0) YaSize<<- 1 YaAngle<<- 18 YaPosition<<- 1 YaThick<<- 1 YaStyle<<- "tf" PHI<<- 30*pi/180 THETA<<- 60*pi/180 FocusPoint<<- c(0,0,0) EyePoint<<- c(5,5,5) ASSIGNLIST<<- list("`","'") SCALEX<<- 1 SCALEY<<- 1 LOGX<<- 0 LOGY<<- 0 TEXFORLEVEL<<- 0 TEXFORLAST<<- list() } #------------------------------------------------------- Appendrow<- function(...) { varargin<- list(...) Nargs<- length(varargin) Out<-c() Nc<- 0 for (I in 1:Nargs) { Dt<- varargin[[I]] Nc<- max(Nc,Ncol(Dt)) if (class(Dt)=="matrix") Dt<-as.numeric(t(Dt)) Out<- c(Out,Dt) } if (Nc>0) { Out<-matrix(Out, nrow=Nc) Out<-t(Out) } else { Out<-c() } return(Out) } Crossprod<-function(a,b) { if (length(a)==3) { Tmp1<-a[2]*b[3]-a[3]*b[2] Tmp2=a[3]*b[1]-a[1]*b[3] Tmp3=a[1]*b[2]-a[2]*b[1] Out=c(Tmp1,Tmp2,Tmp3) } else { Out=a[1]*b[2]-a[2]*b[1] } return(Out) } Datalength<-function(Data) { if (length(Data)==0) return(0) if (mode(Data)=="numeric") return(Nrow(Data)) if (mode(Data)=="character") return(nchar(Data)) if (mode(Data)=="list") return(length(Data)) } Dotprod<-function(a,b) { Tmp=crossprod(a,b) return(Tmp) } Dist<- function(...) # 17.09.17 { varargin<- list(...) a=varargin[[1]] if(length(varargin)==1){ tmp=sqrt(Dotprod(a,a)) return(as.vector(tmp)) } else{ b=varargin[[2]] tmp=sqrt(Dotprod(b-a,b-a)) retun(as.vector(tmp)) } } Member<-function(A,L) { N<-length(L); if (length(N)==0) return(FALSE) for (I in 1:N) { if (class(L)=="list") { Tmp<-L[[I]] } else { Tmp<-L[I] } if (mode(A)=="numeric") { if (Norm(A-Tmp)==0) return(TRUE) } else { if (A==Tmp) return(TRUE) } } return(FALSE) } Norm<-function(V) { Tmp<-as.vector(V); Tmp<-crossprod(Tmp,Tmp); Tmp<-sqrt(Tmp); as.numeric(Tmp) } Ncol<-function(P) { if (class(P)=="matrix") return(ncol(P)) else return(length(P)) } Nrow<-function(P) { if (length(P)==0) return(0) if (class(P)=="matrix") return(nrow(P)) else return(1) } Looprange<- function(a,b) { if (a<=b) return(a:b) return(c()) } Stripblanks<- function(Ch){ Tmp<- gsub(" ","",Ch,fixed=TRUE) return(Tmp) } Derivative<- function(...) { varargin<- list(...) Nargs<- length(varargin) Fstr<- varargin[[1]] Vstr<- varargin[[2]] NvaL<- length(Vstr) Flg<- 0 if(Nargs>=3){ VaL<- varargin[[3]] Flg<- 1 } Str<- paste("deriv(~",Fstr,",c('",Vstr[1],"'",sep="") for(J in Looprange(2,NvaL)){ Str<- paste(Str,",'",Vstr[J],"'",sep="") } Str<- paste(Str,")",sep="") if(NvaL<=3){ Str<- paste(Str,",func=TRUE)",sep="") } else{ Str<- paste(Str,")",sep="") } f<- eval(parse(text=Str)) if(Flg==1){ if (NvaL<=3){ if(NvaL==1){V<- f(VaL[1])} if(NvaL==2){V<- f(VaL[1],VaL[2])} if(NvaL==3){V<- f(VaL[1],VaL[2],VaL[3])} } else{ for(J in 1:NvaL){ Tmp<- paste(Vstr[J],'<-',as.character(VaL[J])) eval(parse(text=Tmp)) } V<- eval(f) } Out<- attr(V,'gradient') Out<- Out[1,] } else{ Out<- f } return(Out) } Integrate<- function(...) { varargin<- list(...) Nargs<- length(varargin) Fstr<- varargin[[1]] Vstr<- varargin[[2]] IntvL<- varargin[[3]] Str<- 'Tmpfun<- function(' Str<- paste(Str,Vstr,'){',sep='') Str<- paste(Str,Fstr,'}',sep='') eval(parse(text=Str)) Tmpfunv<- function(x){sapply(x,Tmpfun)} Out<- 0 for (J in 1:(length(IntvL)-1)){ Tmp<- integrate(Tmpfunv,IntvL[J],IntvL[J+1]) Out<- Out+Tmp[[1]] } return(Out) } #-------------------------------------- ######################### Anglemark<- function(...) { varargin<- list(...) Nargs<- length(varargin) Eps<- 10^(-3) PA<- varargin[[1]] PB<- varargin[[2]] PC=varargin[[3]] r <- 0.5 if (Nargs>=4){ r<- varargin[[4]]*r } Cir<- Circledata(PB,r) Tmp<- IntersectcrvsPp(Cir,Listplot(PA,PB)) P1<- Op(2,Op(1,Tmp)) Tmp<- IntersectcrvsPp(Cir,Listplot(PC,PB)) P2<- Op(2,Op(1,Tmp)) if (abs(P1-P2)1){ R<- Tmp } else{ if (Flg==0){ Ookisa<- Ookisa*Tmp } if (Flg==1){ if (Tmp<5){ Hiraki<- Tmp*Hiraki } else{ Hiraki<- Tmp } } if (Flg==2){ R<- P+Tmp*(Q-P) } else{ R<- P+Yapos*(Q-P) } if (Flg==3){ Futosa<- Tmp } Flg<- Flg+1 } } if (mode(Tmp)=="character"){ Tmp<- grep("=", Tmp) if (length(Tmp)>0){ eval(parse(text=Tmp)) Futosa<- Futosa*Thickness R<- P+Position*(Q-P) } else{ Str<- Tmp } } } Tmp1<- Listplot(c(P,Q)) Tmp2<- Arrowheaddata(R,Q-P,Ookisa,Hiraki,Futosa,Str) Out<- Joingraphics(Tmp1,Tmp2) } ###################################### # 2013.11.13 No Intersect debugged Arrowhead<-function(...) { ## Scaling is implemented ## 12.01.08 Kirikomi varargin<-list(...) Nargs<-length(varargin) P<-varargin[[1]] Houkou<-varargin[[2]] Ookisa<-0.2*YaSize Hiraki<-YaAngle Futosa<-0.5*YaThick Cut<- 0 Str<-YaStyle Flg<- 0 for (I in Looprange(3,Nargs)){ Tmp<-varargin[[I]] if (is.character(Tmp)){ Equal<- grep("=",Tmp,fixed=TRUE) # 12.01.07 from if(length(Equal)>0){ Tmp1<- strsplit(Tmp,"=",fixed=TRUE) Tmp2<- Tmp1[[1]] if (Tmp2[1]=="Cut" || Tmp2[1]=="cut"){ Tmp<- paste("Cut=",Tmp2[2],sep="") eval(parse(text=Tmp)) } }else{ Str<- Tmp } # 12.01.07 upto } if (is.numeric(Tmp) && length(Tmp)==1){ if (Flg==0) Ookisa<-Ookisa*Tmp if (Flg==1){ if (Tmp<5) Hiraki<-Tmp*Hiraki else Hiraki<-Tmp } if (Flg==2) Futosa<-Tmp Flg<-Flg+1 } } Ookisa<-1000/2.54/MilliIn*Ookisa Theta<-Hiraki*pi/180 if (Nrow(Houkou)>1){ P<- Doscaling(P) Houkou<- Doscaling(Houkou) Tmp<-Nearestpt(P,Houkou) A<-Tmp[[1]] I<-floor(Tmp[[2]]) G<-Circledata(P,Ookisa*cos(Theta),N=10) Flg<- 0 # 13.11.13 JL<-seq(I,1,by=-1) for (J in JL){ B<-Ptcrv(J,Houkou) Tmp<-IntersectcrvsPp(Listplot(list(A,B)),G) if (length(Tmp)>0){ Flg<- 1 break } A<-B } if (Flg==0){ # 13.11.13 print("Arrowhead may be too large (no intersect)") return(P) } Houkou<-P-Op(1,Tmp[[1]]) Houkou<- Unscaling(Houkou) P<- Unscaling(P) } P<- Doscaling(P) Houkou<- Doscaling(Houkou) Ev<--1/Norm(Houkou)*Houkou Nv<-c(-Ev[2],Ev[1]) if (length(grep("c",Str))>0){ P<-P-0.5*Ookisa*cos(Theta)*Ev } if (length(grep("b",Str))>0){ P<-P-Ookisa*cos(Theta)*Ev } A<-P+Ookisa*cos(Theta)*Ev+Ookisa*sin(Theta)*Nv B<-P+Ookisa*cos(Theta)*Ev-Ookisa*sin(Theta)*Nv if (length(grep("l",Str))>0){ Tmp<-Listplot(list(A,P,B)) Tmp1<- Unscaling(Tmp) Drwline(Tmp1,Futosa) } else{ C<- P+(1-Cut)*((A+B)/2-P) # 12.01.07 Tmp<- Listplot(list(A,P,B,C,A)) # 12.01.07 Tmp1<- Unscaling(Tmp) Shade(Tmp1) Drwline(Tmp1,1) } } ############################################ # 2013.11.13 No intersect debugged Arrowheaddata<- function(...) { ## Scaling is implemented varargin<- list(...) Nargs<- length(varargin) P<- varargin[[1]] Houkou<- varargin[[2]] Ookisa<- 0.2*YaSize Hiraki<- YaAngle Futosa<- 0 Thickness<- 1 Str<- YaStyle Flg<- 0 for (I in Looprange(3,Nargs)){ Tmp<-varargin[[I]] if (mode(Tmp)=="character"){ Tmp1<-grep("=",Tmp) if (length(Tmp1)>0){ eval(parse(text=Tmp)) Futosa<- Thickness } else{ Str<- Tmp } } if (mode(Tmp)=="numeric" && length(Tmp)==1){ if (Flg==0) Ookisa<-Ookisa*Tmp if (Flg==1){ if (Tmp<5) Hiraki<-Tmp*Hiraki else Hiraki<-Tmp } if (Flg==2) Futosa<-Tmp Flg<-Flg+1 } } Theta<- Hiraki*pi/180 if (Nrow(Houkou)>1){ P<- Doscaling(P) Houkou<- Doscaling(Houkou) Tmp<-Nearestpt(P,Houkou) A<-Tmp[[1]] I<-floor(Tmp[[2]]) G<-Circledata(P,Ookisa*cos(Theta),N=10) Flg<- 0 # 13.11.13 JL<-seq(I,1,by=-1) for (J in JL){ B<- Ptcrv(J,Houkou) Tmp<- IntersectcrvsPp(Listplot(list(A,B)),G) if (length(Tmp)>0){ Flg<- 1 break } A<-B } if (Flg==0){ # 13.11.13 print("Arrowhead may be too large (no intersect)") return(P) } Houkou<-P-Op(1,Tmp[[1]]) Houkou<- Unscaling(Houkou) P<- Unscaling(P) } P<- Doscaling(P) Houkou<- Doscaling(Houkou) Ev<- -1/Norm(Houkou)*Houkou Nv<- c(-Ev[2],Ev[1]) if (length(grep("c",Str))>0){ P<-P-0.5*Ookisa*cos(Theta)*Ev } if (length(grep("b",Str))>0){ P<-P-Ookisa*cos(Theta)*Ev } A<-P+Ookisa*cos(Theta)*Ev+Ookisa*sin(Theta)*Nv B<-P+Ookisa*cos(Theta)*Ev-Ookisa*sin(Theta)*Nv Tmp<- Listplot(A,P,B) Out<- Unscaling(Tmp) return(Out) } ########################################## Arrowline<- function(...) { # 12.01.07 kirikomi varargin<- list(...) Nargs<- length(varargin) P<- varargin[[1]] Q<- varargin[[2]] Futosa<- YaThick Ookisa<- YaSize Hiraki<- YaAngle Yapos<- YaPosition Cutstr<- "Cut=0" Str<- YaStyle Flg<- 0 for (I in Looprange(3,Nargs)){ Tmp<- varargin[[I]] if (is.character(Tmp)){ Equal<- grep("=",Tmp,fixed=TRUE) # 12.01.07 from if(length(Equal)>0){ Tmp1<- strsplit(Tmp,"=") Tmp2<- Tmp1[[1]] if(Tmp2[1]=="Cut" || Tmp2[1]=="cut"){ Tmp<- paste("Cut=", Tmp2[2],sep="") Cutstr<- Tmp } } else{ Str<- Tmp } # 12.01.07 upto } if (is.numeric(Tmp) && length(Tmp)==1){ if (Flg==0) Ookisa<- Ookisa*Tmp if (Flg==1){ if (Tmp<5) Hiraki<- Tmp*Hiraki else Hiraki<- Tmp } if (Flg==2) Yapos<- Tmp if (Flg==3) Futosa<- Tmp Flg<- Flg+1 } } R<- P+Yapos*(Q-P) Drwline(Listplot(c(P,Q)),Futosa) Arrowhead(R,Q-P,Ookisa,Hiraki,Futosa,Cutstr,Str) } ######################################### Assign<- function(...) { varargin<- list(...) Nargs<- length(varargin) if (Nargs==0){ ASSIGNLIST<<- list("`",Prime()) Out<- ASSIGNLIST return() # return("Assign reset done"); } L<- list("`","'") if (Nargs%%2==0){ L<- Mixjoin(L,varargin) ASSIGNLIST<<- L Out<- L return() # return("Assign set done"); } if (Nargs==1){ Fnstr<- varargin[[1]] if (nchar(Fnstr)==0){ # case of "" L<- ASSIGNLIST Out<- c() for (I in seq(1,length(L),by=2)){ Tmp1<- L[[I]] Tmp2<- L[[I+1]] if (length(Tmp2)==1){ Tmp3<- as.character(Tmp2) } else{ if (mode(Tmp2)=="character"){ Tmp3<- Tmp2 } else if (mode(Tmp2)=="list"){ Tmp3<- makeliststr(Tmp2) } else if (mode(Tmp2)=="numeric"){ Tmp3<- "c(" for (J in Looprange(1,length(Tmp2))){ Tmp3<- paste(Tmp3,as.character(Tmp2[J]),sep="") if (J0){ if (length(grep(C,OL))>0){ Tmp<-substring(Ucode,Is,I-1); Str<-paste(VL,Tmp,C,sep="") VL<-Str Is<-I+1; } } else{ Unit<-substring(Ucode,I,I+1); Str<-substring(Ucode,Is,I-1); VL<-paste(VL,Str,sep="") break; } } Valu<-eval(parse(text=VL)); Str<-as.character(Valu); ULEN<<- paste(Str,Unit,sep=""); if (Unit=="cm") MilliIn<<-1000/2.54*Valu if (Unit=="mm") MilliIn<<-1000/2.54*Valu/10 if (Unit=="in") MilliIn<<-1000*Valu if (Unit=="pt") MilliIn<<-1000/72.27*Valu if (Unit=="pc") MilliIn<<-1000/6.022*Valu if (Unit=="bp") MilliIn<<-1000/72*Valu if (Unit=="dd2") MilliIn<<-1000/1238/1157/72.27*Valu if (Unit=="cc") MilliIn<<-1000/1238/1157/72.27*12*Valu; if (Unit=="sp") MilliIn<<-1000/72.27/65536*Valu/10 MARKLEN<<- MARKLENNow*1000/2.54/MilliIn; Str<-paste("{\\unitlength=",ULEN,"%\n",sep=""); cat(Str,file=Wfile,append=TRUE); cat("\\begin{picture}%\n",file=Wfile,append=TRUE); Str<-"("; Tmp<-as.character(round(Dx,digits=6)); Str<-paste(Str,Tmp,",",sep=""); Tmp<-as.character(round(Dy,digits=6)); Str<-paste(Str,Tmp,")(",sep=""); Tmp<-as.character(round(Xm,digits=6)); Str<-paste(Str,Tmp,",",sep=""); Tmp<-as.character(round(Ym,digits=6)); Str<-paste(Str,Tmp,")%\n",sep=""); cat(Str,file=Wfile,append=TRUE); Str<-paste("\\special{pn ",as.character(PenThickInit),"}%\n",sep=""); cat(Str,file=Wfile,append=TRUE); cat("%\n",file=Wfile,append=TRUE); } ################################################# Bowdata<- function(...) #17.09.17 { varargin <- list(...) Nargs <- length(varargin) PA <- varargin[[1]] PB <- varargin[[2]] Cut <- 0 D <- 1/2*Norm(PB-PA) if (Nargs>=3) { H <- varargin[[3]]*D*0.2 } else { H <- D*0.2 } H <- min(H,D) if (Nargs>=4){ Cut <- varargin[[4]] } Ydata <- MakeBowdata(PA,PB,H) C <- Op(1,Ydata) r <- Op(2,Ydata) R1 <- Op(3,Ydata) R2 <- Op(4,Ydata) Rng <- paste("R=c(",as.character(R1),",",as.character(R2),")",sep="") Theta <- (R1+R2)*0.5 BOWMIDDLE <<- list(c(C[1]+r*cos(Theta),C[2]+r*sin(Theta)),Theta) M <- Op(1,BOWMIDDLE) ThetaM <- Op(2,BOWMIDDLE) BOWSTART <<- PA BOWEND <<- PB if (Cut==0){ Pd<- Circledata(c(C,r),Rng) } else{ Alpha <- R1; Beta <- ThetaM-Cut/(2*r) Rng <- paste("Rng=c(",as.character(Alpha),",",as.character(Beta),")",sep="") Pd <- Circledata(c(C,r),Rng) Alpha <- ThetaM+Cut/(2*r); Beta <- R2 Rng <- paste("R=c(",as.character(Alpha),",",as.character(Beta),")",sep="") Tmp <- Circledata(c(C,r),Rng) Pd <- Appendrow(Pd,c(Inf,Inf),Tmp) } } Bowmiddle <- function(...) { varargin <- list(...) Nargs <- length(varargin) if( Nargs==0) { M <- BOWMIDDLE return(M) } if (Nargs==1) { Bdata <- varargin[[1]] A <- Bdata[1,] Dind <- Dataindex(Bdata) Dc <- Nrow(Dind) Tmp <- Dind[Dc,2] B <- Bdata[Tmp,] if (Dc==1) { Tmp1 <- round(Tmp/2) } else { Tmp1 <- Dind[1,2] } D <- Bdata[Tmp1,] B <- B-A D <- D-A Tmp1 <- B[1]*D[2]-D[1]*B[2] Tmp2 <- (Norm(B)^2*D[2]-B[2]*Norm(D)^2)/2 Tmp3 <- -(Norm(B)^2*D[1]-B[1]*Norm(D)^2)/2 C <- c(Tmp2,Tmp3)/Tmp1+A R <- Norm(C-A) B <- B+A V <- (A+B)/2-C V <- V/Norm(V) M <- C+R*V } else { A <- varargin[[1]]; B <- varargin[[2]] D <- 1/2*Norm(B-A) H <- 0.2*D; if (length(varargin)>=3) { Tmp <- varargin[[3]] H <- Tmp*D*0.2 } H <- min(H,D) Ydata <- MakeBowdata(A,B,H) C <- Op(1,Ydata) R <- Op(2,Ydata) T <- (Op(3,Ydata)+Op(4,Ydata))/2 P <- C+R*c(cos(T),sin(T)) #M <- list(P,T) M <- P } return(M) } ########################## # 13.12.19 small movement supported Bowname<- function(...) { varargin <- list(...) Nargs <- length(varargin) Siki <- varargin[[Nargs]] Nargs<- Nargs-1 Dr<- "c" if(Nargs>=1){ Tmp<- varargin[[Nargs]] if(is.character(Tmp)){ Dr<- Tmp Nargs<- Nargs-1 } } if (Nargs==0){ Siki <- varargin[[1]] P <- Op(1,BOWMIDDLE) } else if (Nargs==1){ Bdata <- varargin[[1]] P <- Bowmiddle(Bdata) } else{ A <- varargin[[1]]; B <- varargin[[2]] D <- 1/2*Norm(B-A) Tmp <- varargin[[3]] if (is.character(Tmp)){ H <- D*0.2 } else { H <- Tmp*D*0.2 } H <- min(H,D) Ydata <- MakeBowdata(A,B,H) Tmp <- Bowmiddle(Ydata) P <- Op(1,Tmp) } Expr(P,Dr,Siki) } ########################## # 13.12.19 small movement supported # A,B, ... no longer supported Bownamerot <- function(...) { varargin <- list(...) Nargs <- length(varargin) Eps <- 10^(-6) Flg <- 1 Tmp <- varargin[[Nargs]] if (is.numeric(Tmp) && length(Tmp)==1 && Tmp<0){ Flg <- Tmp Nargs <- Nargs-1 } Siki <- varargin[[Nargs]] Nargs<- Nargs-1 Dr<- "c" if(Nargs>=1){ Tmp<- varargin[[Nargs]] if(is.character(Tmp)){ Dr<- Tmp Nargs<- Nargs-1 } } if (Nargs==0) { P <- Op(1,BOWMIDDLE) A <- BOWSTART B <- BOWEND } else{ Bdata<- varargin[[1]] P<- Bowmiddle(Bdata) A=Bdata[1,] B=Bdata[nrow(Bdata),] Tm<- 0; Tv<- 0 if(Nargs>1){ Tm<- varargin[[2]] if(Nargs>2){ Tv<- varargin[[3]] } } } # else if (Nargs==2) { # Bdata <- varargin[[1]] # P <- Bowmiddle(Bdata) # A <- Bdata[1,] # B <- Bdata[Nrow(Bdata),] # Siki <- varargin[[2]] # } # else { # A <- varargin[[1]]; B <- varargin[[2]] # D <- 1/2*Norm(B-A) # Tmp <- varargin[[3]] # if (mode(Tmp)=="character") { # H <- 0.2*D; Siki <- Tmp # } # else { # H <- Tmp*D*0.2; Siki <- varargin[[4]] # } # H <- min(H,D) # Ydata <- MakeBowdata(A,B,H) # C <- Op(1,Ydata) # R <- Op(2,Ydata) # T <- (Op(3,Ydata)+Op(4,Ydata))/2 # P <- C+R*c(cos(T),sin(T)) # } if (A[1]>B[1]+Eps){ Tmp <- A A <- B B <- Tmp } if (Flg>0) { Tmp <- B-A } else{ Tmp <- A-B } Exprrot(P,Tmp,Tm,Tv,Siki) } CalcHeight<-function(Hoko,Moji) { D<-0 H<-substring(Hoko,1,1) Tmp<-paste("\\settoheight{\\Height}{",Moji,"}",sep="") Str<-c(Tmp) Tmp=paste("\\settodepth{\\Depth}{",Moji,"}",sep="") Str<-c(Str,Tmp) if (H=="n") Str<-c(Str,"\\setlength{\\Height}{\\Depth}") if (H=="s") Str<-c(Str,"\\setlength{\\Height}{-\\Height}") if (H=="c") { Str<-c(Str,"\\setlength{\\Height}{-0.5\\Height}") Str<-c(Str,"\\setlength{\\Depth}{0.5\\Depth}") Str<-c(Str,"\\addtolength{\\Height}{\\Depth}") } for (I in 1:length(Str)) cat(Str[I],file=Wfile,append=TRUE) cat("%\n",file=Wfile,append=TRUE) } ######################### CalcWidth<-function(Hoko,Moji) { D<-0; H<-substring(Hoko,2,2) if (H=="e") D<-0 if (H=="w") D<--1.0 if (H=="c") D<--0.5 Str1<-paste("\\settowidth{\\Width}{",Moji,"}",sep="") Tmp<-as.character(D) Str2<-paste("\\setlength{\\Width}{",Tmp,"\\Width}",sep="") cat(Str1,file=Wfile,append=TRUE) cat(Str2,file=Wfile,append=TRUE) cat("%\n",file=Wfile,append=TRUE) } ######################### # 17.09.17 # 17.09.24 Circledata<- function(...){ varargin<- list(...) Nargs<- length(varargin) Cr<- varargin[[1]] C=Cr[1:2] if(length(Cr)==4){ ra=Norm(C-Cr[3:4]) Nop=2 } else{ ra=Cr[3] Nop=2 } R=c(0,2*pi) N=50 for (I in Looprange(Nop,Nargs)){ Tmp<- varargin[[I]] if(is.character(Tmp)){ Tmp1=regexpr("=",Tmp) #17.09.24from Tmp2=substring(Tmp,Tmp1+1,nchar(Tmp)) Tmp1=substring(Tmp,1,Tmp1) Tmp1=gsub("NUM", "N", toupper(Tmp1)) Tmp1=gsub("RNG", "R", Tmp1) Tmp=paste(Tmp1,Tmp2,sep="") #17.09.24upto eval(parse(text=Tmp)) } } Dt<- (R[2]-R[1])/N T <- seq(R[1],R[2],by=Dt) X <- C[1]+ra*cos(T) Y <- C[2]+ra*sin(T) XY<- c(X,Y) P<- matrix(XY,ncol=2) return(P) } ######################### # 13.12.19 Closefile<-function(...) { varargin<- list(...) if(length(varargin)>=1){ Pa<- varargin[[1]] if(is.character(Pa)){ if(Pa=="1") Endpicture(1) if(Pa=="0") Endpicture(0) } } Wfile<<-"" } ######################### Closepar<- function() { S<- "%\n\\end{minipage}" cat(S,file=Wfile,append=TRUE) Closephr() } #################################### Closephr<- function() { cat("%\n}%\n",file=Wfile,append=TRUE) } ##################################### Dataindex<-function(P) { # Inf;Inf : Terminator Ndm<-c() if (length(P)==0) return(Ndm) N1<-1 Flg<-0 for (J in 1:Nrow(P)) { if (P[J,1]==Inf) { Ndm<-Appendrow(Ndm,c(N1,J-1)) N1<-J+1; if (P[N1,1]==Inf) { Flg<-1; break; } } } if (Flg==0) { Ndm<-Appendrow(Ndm,c(N1,Nrow(P))) } if (class(Ndm)=="numeric") { Tmp<-matrix(Ndm,nrow=1) Ndm<- Tmp } return(Ndm) } ################################ Dashline<- function(...) { varargin<- list(...) Nargs<- length(varargin) Nall<- Nargs; Sen<- 1 ; Gap<- 1 Tmp<- varargin[[Nall]] if (mode(Tmp)=="numeric" && length(Tmp)==1 && Tmp>0){ Tmp1<- varargin[[Nall-1]] if (mode(Tmp1)=="numeric" && length(Tmp1)==1 && Tmp1>0){ Sen<- Tmp1; Gap<- Tmp Nall<- Nall-2 } else{ Sen<- Tmp; Gap<- Sen Nall<- Nall-1 } } Sen<- 1000/2.54/MilliIn*Sen Gap<- 1000/2.54/MilliIn*Gap for (N in Looprange(1,Nall)){ Pdata<- varargin[[N]] if (Mixtype(Pdata)==1){ Pdata<- list(Pdata) } for (II in 1:length(Pdata)){ Figdata<- Op(II,Pdata) Makehasen(Figdata,Sen,Gap,0) } } } ############################################## Diagcelldata<- function(Tb,Nc,Nr) { Tmp<- Findcell(Tb,Nc,Nr) C<- Tmp[[1]] Dx<- Tmp[[2]] Dy<- Tmp[[3]] Pne<- C+c(Dx,Dy) Pnw<- C+c(-Dx,Dy) Psw<- C+c(-Dx,-Dy) Pse<- C+c(Dx,-Dy) Tmp1<- Listplot(Pnw,Pse) Tmp2<- Listplot(Pne,Psw) list(Tmp1,Tmp2) } ############################################## # 11.01.07 Dividegraphics<- function(Pd) { if (length(Pd)==0){ return(Pd) } DtL<- Flattenlist(Pd) OutL<- list() for (J in 1:length(DtL)){ Dt<- as.matrix(DtL[[J]]) Ndm<- Dataindex(Dt) for (I in Looprange(1,Nrow(Ndm))){ Fd<- Dt[Ndm[I,1]:Ndm[I,2],] OutL<- c(OutL,list(Fd)) } } return(OutL) } ############################################## # 13.05.03 Dividetable<- function(Tb) { G<- Tb[[1]] Gw<- G[[1]] Gt<- G[Tb[[2]]] Gy<- G[Tb[[3]]] list(Gw,Gt,Gy) } ################################################ Doscaling<- function(G) { GLg<- G if (class(GLg)=="numeric") { if (LOGX==1) GLg[1]<- log(G[1], base=10) if (LOGY==1) GLg[2]<- log(G[2], base=10) Tmp<-c(SCALEX*GLg[1],SCALEY*GLg[2]) return(Tmp) } else { if (LOGX==1) GLg[,1]<- log(G[,1],base=10) if (LOGY==1) GLg[,2]<- log(G[,2],base=10) Tmp1<-matrix(c(SCALEX,0,0,SCALEY),nrow=2) Tmp<-GLg %*% Tmp1 return(Tmp) } } ######################################## Dotfilldata<- function(...) { ## Scaling is implemented varargin<- list(...) Nargs<- length(varargin) ShaL<- list() Eps<- 0.01 Kakudo<- 45 Kosa<- 0.5 Tmp<- Doscaling(c(XMIN,YMIN)) Xmn<- Tmp[1]; Ymn<- Tmp[2] Tmp<- Doscaling(c(XMAX,YMAX)) Xmx<- Tmp[1]; Ymx<- Tmp[2] for (N in seq(Nargs,1,by=-1)){ Tmp<- varargin[[N]] if (Mixtype(Tmp)!=1){ break } } if (N0){ for (J in Looprange(1,length(Sha))){ Tmp<- Op(J,Sha) Q<- Tmp[1,] R<- Tmp[2,] Tmp<- Dotprod(Q-P,V)/Kankaku K1<- ceiling(Tmp) if (abs(K1-Tmp)0){ for (J in 1:length(Sha)){ Tmp<- Op(J,Sha) Q<- Tmp[1,] R<- Tmp[2,] Tmp<- Dotprod(Q-P,V)/Kankaku K1<- ceiling(Tmp) if (abs(K1-Tmp)0){ for (J in 1:length(Sha)){ Tmp<- Op(J,Sha) Q<- Tmp[1,] R<- Tmp[2,] Tmp<- Dotprod(Q-P,V)/Kankaku K1<- ceiling(Tmp) if (abs(K1-Tmp) 1) { Seg <- Lenall/(Nten-1) } else { Seg <- Lenall } Eps <- 10^(-6)*Seg PPd<-c() Hajime <- 1 for (I in Looprange(0,Nten-1)) { Len <- Seg*I if (I>0) { J <- Hajime while( Len>=Lenlist[J]+Eps) { J <- J+1 } Hajime <- J-1 } T <- (Len-Lenlist[Hajime])/ (Lenlist[Hajime+1]-Lenlist[Hajime]) P <- Data[Hajime,]+T*(Data[Hajime+1,]-Data[Hajime,]) PPd<-Appendrow(PPd,P) if (I==Nten-1) { if (Norm(P-Data[1,])80){ cat("%\n",file=Wfile,append=TRUE) Mojisu<-0 } } if (Mojisu!=0){ cat("%\n",file=Wfile,append=TRUE) } cat("\\special{fp}%\n",file=Wfile,append=TRUE) } } } Str<-"%" if (Thick>0){ Tmp<-PenThick/PenThickInit Setpen(Tmp) } } ########################################### Drwpt<-function(...) { ## Scaling is implemented varargin<-list(...) Nargs<-length(varargin) if (TenSize>TenSizeInit){ N<- round(6*sqrt(TenSize/TenSizeInit)) } else{ N<-4 } Tmp<- varargin[[Nargs]] if (mode(Tmp)=="numeric"){ if (length(Tmp)>1){ Kosa<- 1; All<- Nargs } else{ Kosa<- Tmp; All<- Nargs-1 } } else if (mode(Tmp)=="list"){ Kosa<- 1; All<- Nargs } CL<-c() for (J in 0:N){ Tmp<- TenSize*0.5*1000/2.54/MilliIn Tmp<- Tmp*c(cos(pi/4+J*2*pi/N),sin(pi/4+J*2*pi/N)) CL<- append(CL,Tmp) } CL<- matrix(CL,nrow=2) CL<- t(CL) for (II in Looprange(1,All)){ MS<- varargin[[II]] MS=Flattenlist(MS) #17.10.11 if (mode(MS)=="numeric"){ MS<- list(MS) } for (I in Looprange(1,length(MS))){ P<- MS[[I]] if (InWindow(P)!="i") next P<- Doscaling(P) PL<-c() for (J in 0:N){ PL<- c(PL,P+CL[J+1,]) } PL<-matrix(PL,nrow=2) PL<-t(PL) Mojisu<-0 for (J in 1:Nrow(PL)){ Q<- PL[J,] X<- as.character(round(MilliIn*Q[1])) Y<- as.character(-round(MilliIn*Q[2])) Str<- paste("\\special{pa ",X," ",Y,"}",sep="") cat(Str,file=Wfile,append=TRUE) Mojisu<- Mojisu+nchar(Str) if (Mojisu>80){ cat("#\n",file=Wfile,append=TRUE) } Mojisu=0 } Str1<- paste("\\special{sh ",as.character(Kosa),"}",sep="") Str2<- "\\special{fp}%\n" cat(Str1,file=Wfile,append=TRUE) cat(Str2,file=Wfile,append=TRUE) } } } ###################################################### Drwxy<-function(...) { varargin<-list(...) Nargs <- length(varargin) Tmp<-grep("arrow", ZIKU) if (length(Tmp)>0) { Arrowline(c(XMIN,GENTEN[2]),c(XMAX,GENTEN[2]),ARROWSIZE) Arrowline(c(GENTEN[1],YMIN),c(GENTEN[1],YMAX),ARROWSIZE) } else { Drwline(Listplot(c(XMIN,GENTEN[2]),c(XMAX,GENTEN[2]))) Drwline(Listplot(c(GENTEN[1],YMIN),c(GENTEN[1],YMAX))) } Letter(c(XMAX,GENTEN[2]),XPOS,XNAME) Letter(c(GENTEN[1],YMAX),YPOS,YNAME) Letter(GENTEN,OPOS,ONAME); } ########################################## # 10.12.04 Enclosing<- function(...) { varargin<- list(...) Nargs<- length(varargin) P<- varargin[[1]] if (Mixtype(P)==2){ Tmp<- Op(1,P) if (mode(Tmp)!="numeric" || length(Tmp)>1){ AnsL<- EnclosingS(...) AnsL<- Joincrvs(AnsL) # 10.12.04 return(AnsL) } } } ######################################### EnclosingS<- function(...) { varargin<- list(...) Nargs<- length(varargin) AnsL<- list() PdataL<- varargin[[1]] Nall<-length(PdataL) Eps<- 10^(-3) EEps<- 0.1 S<- c() Flg<- 0 for (I in Looprange(2,Nargs)){ Tmp<- varargin[[I]] if (mode(Tmp)=="numeric" && Nrow(Tmp)==1 && length(Tmp)>1){ S<- Tmp } if (mode(Tmp)=="numeric" && length(Tmp)==1){ if (Flg==0){ Eps<- Tmp Flg=Flg+1 } else{ EEps<- Tmp } } } F<- Op(1,PdataL); G<- Op(Nall,PdataL) KL<- IntersectcrvsPp(F,G) if (length(KL)==1){ Tmp<- Op(1,KL) P<- Op(1,Tmp) T1<- Op(2,Tmp) } if (length(KL)==0){ if (Numptcrv(F)>Numptcrv(G)){ Tmp<- Nearestpt(F,G) P<- Op(1,Tmp) T1=Op(2,Tmp) } else{ Tmp<- Nearestpt(G,F) P<- Op(3,Tmp) T1<- Op(4,Tmp) } } if (length(KL)>=2){ if (length(S)==0){ return("No Start Point") } Tmp<- Op(1,KL) P<- Op(1,Tmp) T1<- Op(2,Tmp) Tmp<- Norm(P-S) for (I in Looprange(2,length(KL))){ Tmp1<- Op(1,Op(I,KL)) Tmp2<- Norm(Tmp1-S) if (Tmp21) P<- Q if (N==Nall){ Q=S } else{ Flg<- 0 G<- Op(N+1,PdataL) KL<- IntersectcrvsPp(G,F) if (length(KL)==1){ Tmp<- Op(1,KL) Q<- Op(1,Tmp) T3<- Op(2,Tmp) Flg<- 10 } if (length(KL)==0) Flg<- 1 if (length(KL)>=2){ # Maple bug? Tmp1<- Op(1,Op(1,KL)) Tmp2<- Op(1,Op(2,KL)) Tmp<- Norm(Tmp1-Tmp2) if (TmpNumptcrv(G)){ Tmp<- Nearestpt(F,G) Q<- Op(1,Tmp) T3<- Op(4,Tmp) Flg<- 10 } else{ Tmp<- Nearestpt(G,F) Q<- Op(3,Tmp) T3<- Op(2,Tmp) Flg<- 10 } } if (Flg<10){ T2<- Inf for (I in Looprange(1,length(KL))){ Dt<- Op(I,KL) Tmp1<- Op(1,Dt) Tmp<- Op(3,Dt) Tmp2<- Paramoncrv(Tmp1,Tmp,F) Tmp3<- Op(2,Dt) if (Tmp2>T1+Eps && Tmp20){ eval(parse(text=Op(I,StrL))) } } } ######################################### Expr<-function(...) { ## Scaling is implemented varargin<-list(...) Nargs<-length(varargin) Irng<-c(seq(from=1,to=Nargs,by=3)) for (I in Irng) { Tmp<-varargin[[I]] P<- Doscaling(Tmp) X<-P[1] Y<-P[2] Houkou<-varargin[[I+1]] Mojiretu<-paste("$",varargin[[I+2]],"$",sep="") Hset<-Houkou Vhoko<-"c" if (length(grep("n",Hset))>0) { Vhoko<-"n"; Y<-Y+MEMORI } if (length(grep("s",Hset))>0) { Vhoko<-"s"; Y<-Y-MEMORI } Hhoko<-"c" if (length(grep("e",Hset))>0) { Hhoko<-"e"; X<-X+MEMORI } if (length(grep("w",Hset))>0) { Hhoko<-"w"; X<-X-MEMORI } Hoko<-paste(Vhoko,Hhoko,sep="") Suu<-"+-.0123456789" SuuL<-Suu J<-1; Dstr<-"" while (J<=nchar(Houkou)) { Tmp<-substring(Houkou,J,J) if (length(grep(Tmp,Suu))>0) { if (Dstr=="") Hk<-substring(Houkou,J-1,J-1) Dstr<-paste(Dstr,Tmp,sep="") } else { if (Dstr!="") { Nmbr<-as.numeric(Dstr) D<-Nmbr*MEMORI if (Hk=="n") Y<-Y+D if (Hk=="s") Y<-Y-D if (Hk=="e") X<-X+D if (Hk=="w") X<-X-D Dstr<-"" } } J<-J+1 } if (Dstr!="") { Nmbr<-as.numeric(Dstr) D<-Nmbr*MEMORI; if (Hk=="n") Y<-Y+D if (Hk=="s") Y<-Y-D if (Hk=="e") X<-X+D if (Hk=="w") X<-X-D } CalcWidth(Hoko,Mojiretu) CalcHeight(Hoko,Mojiretu) cat("\\put(",file=Wfile,append=TRUE) Tmp1<- sprintf("%7.7f",X) # 11.07.19 Tmp2<- sprintf("%7.7f",Y) # 11.07.19 Str<-paste(Tmp1,",",Tmp2,sep="") cat(Str,file=Wfile,append=TRUE) Tmp<-"){\\hspace*{\\Width}" Str<-paste(Tmp,"\\raisebox{\\Height}{",Mojiretu,"}}%\n",sep="") cat(Str,file=Wfile,append=TRUE) cat("%\n",file=Wfile,append=TRUE) } } ########################################## Exprrot<- function(...) { varargin<- list(...) P<- varargin[[1]] V<- varargin[[2]]; N<- 3 P<- Doscaling(P) V<- Doscaling(V) Tmov<- 0 Tmp<- varargin[[N]] if (mode(Tmp)=="numeric"){ Tmov<- Tmp; N<- N+1 } Nmov<- 0 Tmp<- varargin[[N]] if (mode(Tmp)=="numeric"){ Nmov<- Tmp; N<- N+1 } Mojiretu<- paste("$",varargin[[N]],"$",sep="") Tv<- 1/Norm(V)*V Nv<- c(-Tv[2],Tv[1]) P<- P+MEMORI*Tmov*Tv+MEMORI*Nmov*Nv Tmp<- acos(V[1]/Norm(V)) Theta<- round(Tmp*180/pi) if (V[2]>=0){ Units<- "" } else{ Units<- "units=-360," } Tmp<- paste("\\rotatebox[",Units,"origin=c]{",as.character(Theta),sep="") Tmp<- paste(Tmp,"}{",Mojiretu,"}",sep="") Letter(P,"c",Tmp) } ###################################################### Findcell<- function(...) { varargin<- list(...) Nargs<- length(varargin) TbL<- varargin[[1]] Ag<- varargin[[2]] Alpha<- "-ABCDEFGHIJKLMNOPQRSTUVWXYZ" if (mode(Ag)=="character"){ Clm<- c() Rstr<- "" for (I in Looprange(1,nchar(Ag))){ C<- substr(Ag,I,I) C<- toupper(C) Tmp<- strsplit(Alpha,C) Tmp<- Tmp[[1]] if (length(Tmp)>1){ Tmp1<- nchar(Tmp[1]) Clm<- c(Clm,Tmp1) } else{ Rstr<- paste(Rstr,C,sep="") } } Nrg<- 0 for (I in seq(length(Clm),1,by=-1)){ Tmp<- Clm[I] Tmp1<- length(Clm)-I Nrg<- Nrg+Tmp*26^Tmp1 } Mrg<- eval(parse(text=Rstr)) if (Nargs>=3){ Ag<- varargin[[3]] Clm<- c() Rstr<- "" for (I in Looprange(1,nchar(Ag))){ C<- substr(Ag,1,1) C<- toupper(C) Tmp<- strsplit(Alpha,C) if (length(Tmp)>1){ Clm<- c(Clm,Tmp+1) } else{ Rstr<- paste(Rstr,C,sep="") } } Nrg2<- 0 for (I in seq(length(Clm),1,by=-1)){ Tmp<- Clm[I] Tmp1<- length[Clm]-I Nrg2<- Nrg2+Tmp*26^Tmp1 } Nrg<- c(Nrg,Nrg2) Tmp=eval(parse(text=Rstr)) Mrg<- c(Mrg,Tmp) } } else{ Nrg<- varargin[[2]] Mrg<- varargin[[3]] } if (length(Mrg)==1){ m1<- Mrg; m2<- m1+1 } else{ m1<- Mrg[1]; m2<- Mrg[2] # 10.12.12 } if (length(Nrg)==1){ n1<- Nrg; n2<- n1+1 } else{ n1<- Nrg[1]; n2<- Nrg[2] } n1<- n1+1; n2<- n2+1 m1<- m1+1; m2<- m2+1 Hind<- TbL[[2]] Vind<- TbL[[3]] Tmp<- TbL[[1]] HL<- Tmp[Hind] Tmp1<- Op(1,TbL[[4]]) Tmp2<- Op(2,TbL[[4]]) HL<- Mixjoin(list(Tmp1),HL,list(Tmp2)) VL<- Tmp[Vind] Tmp1<- Op(1,TbL[[5]]) Tmp2<- Op(2,TbL[[5]]) VL<- Mixjoin(list(Tmp1),VL,list(Tmp2)) Tmp<- TbL[[6]] Tmp1<- Listplot(c(Ptsw(Tmp),Ptnw(Tmp))) Tmp2<- Listplot(c(Ptse(Tmp),Ptne(Tmp))) HL<- Mixjoin(list(Tmp1),HL,list(Tmp2)) Tmp1<- Listplot(c(Ptnw(Tmp),Ptne(Tmp))) Tmp2<- Listplot(c(Ptsw(Tmp),Ptse(Tmp))) VL<- Mixjoin(list(Tmp1),VL,list(Tmp2)) Tmp<- HL[[n1]] if (mode(Tmp)=="numeric"){ H1<- Tmp[1,1] } else{ Tmp1<- Tmp[[1]] H1<- Tmp1[1,1] } Tmp<- HL[[n2]] if (mode(Tmp)=="numeric"){ H2<- Tmp[1,1] } else{ Tmp1<- Tmp[[1]] H2<- Tmp1[1,1] } Tmp<- VL[[m1]] if (mode(Tmp)=="numeric"){ V1<- Tmp[1,2] } else{ Tmp1<- Tmp[[1]] V1<- Tmp1[1,2] } Tmp<- VL[[m2]] if (mode(Tmp)=="numeric"){ V2<- Tmp[1,2] } else{ Tmp1<- Tmp[[1]] V2<- Tmp1[1,2] } Pt<- c((H1+H2)/2,(V1+V2)/2) High<- (V1-V2)/2 Wide<- (H2-H1)/2 Out<- list(Pt,Wide,High) return(Out) } ############################################ Flattenlist<- function(...){ varargin<- list(...) Nargs<- length(varargin) Out<- list() for(N in Looprange(1,Nargs)){ D<- varargin[[N]] if(is.data.frame(D) || !is.list(D)){ # modify Out<- c(Out,list(D)) } else{ for(I in Looprange(1,length(D))){ Ds<- D[[I]] Tmp<- Flattenlist(Ds) Out<- c(Out,Tmp) } } } return(Out) } ############################################ Fontsize<- function(Ookisa) { Str<- "%" S<- substr(Ookisa,1,1) if (S=="n"){ Str<- "\\normalsize%" } if (S=="s"){ if (nchar(Ookisa)==1){ Tmp<- "n" } else{ Tmp<- substr(Ookisa,2,2) } if (Tmp=="s"){ Str<- "\\scriptsize%" } else{ Str<- "\\small%" } } if (S=="f"){ Str<- "\\footnotesize%" } if (S=="t"){ Str<- "\\tiny%" } if (S=="l"){ Str<- "\\large%" } if (S=="L"){ if (nchar(Ookisa)==1){ Tmp<- "a" } else{ Tmp<- substr(Ookisa,2,2) } if (Tmp=="a"){ Str<- "\\Large%" } else{ Str<- "\\LARGE%" } } if (S=="h"){ Str<- "\\huge%" } if (S=="H"){ Str<- "\\Huge%" } cat(Str,file=Wfile,append=TRUE) cat("\n",file=Wfile,append=TRUE) } ########################################## Fracform<- function(...) { varargin<- list(...) Eps<- 10^(-10) Nmax<- 1/Eps Nargs<- length(varargin) X<- varargin[[1]] Nr<- Nrow(X) X<- as.matrix(X,nrow=Nr) for (I in Looprange(2,Nargs)){ Tmp<- varargin[[I]] if (mode(Tmp)!="numeric"){ next } if (Tmp>1){ Nmax<- Tmp } else if (Tmp>0){ Eps<- Tmp } } Tmp<- rep("",length(X)) Out<- matrix(Tmp,nrow=nrow(X)) for (I in Looprange(1,nrow(X))){ for (J in Looprange(1,ncol(X))){ Dt<- X[I,J] if (mode(Dt)=="character"){ Dt<- eval(parse(text=Dt)) } R<- 1 N<- 0 Rmin<- R Nr<- N while (R>Eps && N0) { Tmp<- Mixjoin(ShaL, list(Sha)) ShaL <- Tmp Sha<- Makeshasen(PtnL,PA+I*Kankaku*Vm,V,Bdy) I <- I+1 } Sha<- Makeshasen(PtnL,PA-Kankaku*Vm,V,Bdy) I<- 2 while (length(Sha)>0) { for (J in 1:length(Sha)) { Tmp<- Mixjoin(ShaL,list(Sha[[J]])) ShaL<- Tmp } Sha<- Makeshasen(PtnL,PA-I*Kankaku*Vm,V,Bdy) I<- I+1 } } else { Delta<- c(Xmn,Ymn)-StartP K1<- trunc(Dotprod(Delta,Vm)/Kankaku) Delta<- c(Xmx,Ymn)-StartP K2<- trunc(Dotprod(Delta,Vm)/Kankaku) Delta<- c(Xmx,Ymx)-StartP K3<- trunc(Dotprod(Delta,Vm)/Kankaku) Delta<- c(Xmn,Ymx)-StartP K4<- trunc(Dotprod(Delta,Vm)/Kankaku) IM<- max(K1,K2,K3,K4) Im<- min(K1,K2,K3,K4) for (I in Im:IM) { Sha<- Makeshasen(PtnL,StartP+I*Kankaku*Vm,V,Bdy) for (J in Looprange(1,length(Sha))) { Tmp<- Mixjoin(ShaL, list(Sha[[J]])) ShaL<- Tmp } } } ShaLs<-list() for (I in Looprange(1,length(ShaL))) { Tmp<- ShaL[[I]] Tmp1<- Unscaling(Tmp) Tmp2<- Mixjoin(ShaLs, list(Tmp1)) ShaLs<- Tmp2 } ShaL<- ShaLs return(ShaL) } ###################################### Htickmark<- function(...) { ## Scaling is implemented varargin<- list(...) Nargs<- length(varargin) ArgsL<- varargin if (mode(ArgsL[[1]])=="character"){ Str<- ArgsL[[1]] Tmp<- strsplit(Str,"m") Tmp<- Tmp[[1]] if (length(Tmp)>1){ I<- nchar(Tmp[1])+1 } else{ I<- 0 } Tmp<- strsplit(Str,"n") Tmp<- Tmp[[1]] if (length(Tmp)>1){ J<- nchar(Tmp[1])+1 } else{ J<- 0 } Tmp<- strsplit(Str,"r") Tmp<- Tmp[[1]] if (length(Tmp)>1){ K=nchar(Tmp[1])+1 } else{ K<- 0 } if (K>0){ S<- substr(Str,K+1,nchar(Str)) R<- as.numeric(S) if (is.na(R)){ R<- 1 } } else{ R<- 1 K<- nchar(Str)+1 } if (J>0){ S<- substr(Str,J+1,K-1) Dn<- as.numeric(S) if (is.na(Dn)){ Dn<- 1 } } else{ Dn<- 1000 J<- nchar(Str)+1 } S<- substr(Str,I+1,J-1) Dm<- as.numeric(S) if (is.na(Dm)){ Dm<- 1 } ArgsL<- list() for (I in Looprange(1, floor((XMAX-GENTEN[1])/Dm))){ ArgsL<- Mixjoin(ArgsL,I*Dm) if (I-floor(I/Dn)*Dn==0){ Str<- as.character(I*Dm*R) ArgsL<- Mixjoin(ArgsL,Str) } } for (I in seq(-1,ceiling((XMIN-GENTEN[1])/Dm),by=-1)){ ArgsL<- Mixjoin(ArgsL,I*Dm) if (I-floor(I/Dn)*Dn==0){ Str<- as.character(I*Dm*R) ArgsL<- Mixjoin(ArgsL,Str) } } } MemoriList<- list() Memori<- list() for (N in 1:length(ArgsL)){ Dt<- ArgsL[[N]] if (mode(Dt)=="numeric" && length(Dt)>1){ if (length(Memori)>0){ MemoriList<- Mixjoin(MemoriList,list(Memori)) } Memori<- list(Dt[1],Dt[2]) next } if (mode(Dt)=="character"){ Memori<- Mixjoin(Memori,Dt) } else{ if (length(Memori)>0){ MemoriList<- Mixjoin(MemoriList,list(Memori)) } Memori<- list(Dt,GENTEN[2]) } } MemoriList<- Mixjoin(MemoriList,list(Memori)) for (N in 1:length(MemoriList)){ Dt<- MemoriList[[N]] Ndt<- length(Dt) X=Op(1,Dt) Y=Op(2,Dt) Tmp<-Doscaling(c(X,Y)) X<- Tmp[1] Y<- Tmp[2] Moji<- Op(Ndt,Dt) Tmp1<- Unscaling(c(X,Y+MARKLEN)) Tmp2<- Unscaling(c(X,Y-MARKLEN)) Fd<- Listplot(c(Tmp1,Tmp2)) Drwline(Fd) if (Ndt==3){ Tmp<-Unscaling(c(X,Y-MARKLEN)) Expr(Tmp,"s",Moji) } if (Ndt==4){ Houkou<- Op(3,Dt) Tmp<-grep("s",Houkou) if (length(Tmp)>0){ Tmp<-Unscaling(c(X,Y-MARKLEN)) Expr(Tmp,Houkou,Moji) } else{ Tmp<- Unscaling(c(X,Y+MARKLEN)) Expr(Tmp,Houkou,Moji) } } cat("%\n",file=Wfile,append=TRUE) } } ############################################# # 2013.08.07 Integrate<- function(Fs,Vs, Intv){ if(is.function(Fs)){ Fn<- Fs } else{ Str<- paste("Fn<- function(",Vs, ") ", Fs, sep="") eval(parse(text=Str)) } Tmp<- integrate(Fn, Intv[[1]], Intv[[2]]) Out<- Tmp[[1]] return(Out) } ############################################# Intersectcrvs<-function(...) { varargin<-list(...) Nargs<-length(varargin) Eps<-10^(-4) Tmp<-varargin[[Nargs]] if (mode(Tmp)=="numeric" && length(Tmp)==1) { Eps<-Tmp } G1<-varargin[[1]] if (mode(G1)=="numeric") { G1<-list(G1) } G2<-varargin[[2]] if (mode(G2)=="numeric") { G2<-list(G2) } PL<-list() for (N in 1:length(G1)) { for (M in 1:length(G2)) { KL<-IntersectcrvsPp(G1[[N]],G2[[M]],Eps) for (I in Looprange(1,length(KL))) { Tmp<-KL[[I]] P<-Tmp[1] PL<-append(PL,P) } } } return(PL) } ########################################### IntersectcrvsPp<-function(...) { varargin<-list(...) Nargs<-length(varargin) G1<-varargin[[1]]; G2<-varargin[[2]] Eps<- 10.0^(-4) if (Nargs>2) Eps<-varargin[[3]] SqEps<- 10.0^(-10) Eps2<- 0.1 if (Nargs>3) Eps2<-varargin[[4]] Data1<-G1 Data2<-G2 if (Nrow(Data1)==Nrow(Data2)) { Tmp<-seq(Nrow(Data2),1, by=-1) Tmp1<-Data2[Tmp,] Eps0<-10^(-6) Tmp2<-Norm(Data1-Data2) Tmp3<-Norm(Data1-Tmp1) if (Tmp20) { Tmp<-KL1[[1]] P<-Tmp[[1]] T<-Tmp[[2]] I<-Tmp[[3]] J<-Tmp[[4]] Tmp<-list(P,I+T,J) KL<-list(Tmp) } for (N in Looprange(2,length(KL1))) { Tmp<-KL1[[N]] P<-Tmp[[1]] Flg<-0 for (K in 1:length(KL)) { if (1>length(KL)) break Tmp<-KL[[K]] if (Norm(P-Tmp[[1]])^20){ # 13.12.20 Tmp1<- varargin[[Nall-1]] if (is.numeric(Tmp1) && length(Tmp1)==1 && Tmp1>0){ # 13.12.20 Sen<- Tmp1; Gap<- Tmp Nall<- Nall-2 } else{ Sen<- Tmp; Gap<- Sen Nall<- Nall-1 } } Sen<- 1000/2.54/MilliIn*Sen Gap<- 1000/2.54/MilliIn*Gap for (N in Looprange(1,Nall)){ Figdata<- varargin[[N]] Makehasen(Figdata,Sen,Gap,1) } } ######################################### Invert<- function(Pd) { OutL=Pd[nrow(Pd):1,] return(OutL) } ############################################ InWindow<-function(PA) { Eps<-10.0^(-6); X<-PA[1]; Y<-PA[2]; if (X>XMIN-Eps && XYMIN-Eps && YEps){ PtL<- Appendrow(PtL,Qd) } else{ if(is.null(nrow(Qd))){ Qd<- as.matrix(Qd,nrow=1)} PtL<- Appendrow(PtL,Qd[2:nrow(Qd),]) # 11.06.25 } } return(PtL) } ######################################## # 2011.11.02 Joingraphics<- function(...) { varargin<- list(...) Ls<- Flattenlist(varargin) N<- length(Ls) Tp<- Ls[[N]] Listflg<- 0 if ( is.character(Tp)){ Tmp<- toupper(substr(Tp,1,1)) if(Tmp=="L"){ Listflg<- 1 } N<- N-1 Ls<- Ls[1:N] } if(Listflg==1){ P<- Ls } else{ P<- c() for (I in 1:N){ Tmp<- Ls[[I]] P<- Appendrow(P,c(Inf,Inf)) P<- Appendrow(P,Tmp) } P<- P[2:nrow(P),] } return(P) } ######################################## Kouten<- function(PA,V,P,Q) { Eps<- 10.0^(-6) A1<- PA[1]; A2<- PA[2] V1<- V[1]; V2<- V[2] P1<- P[1]; P2<- P[2] U1<- Q[1]-P1; U2<- Q[2]-P2 Tmp<- Norm(P-Q)*Norm(V) if (Tmp==0) { Out<- list(Inf,-Inf) return(Out) } D<- U1*V2-U2*V1 if (abs(D)/Tmp1+Eps || S=5) { Eps<-varargin[[5]] } Eps2 <- 0.2 if (Nargs>=6) { Eps2<-varargin[[6]] } Eps<-min(Eps2,Eps/sqrt(Sv2)) P1<-(P[1]*V[1]+P[2]*V[2])/Sv2 P2<-(-P[1]*V[2]+P[2]*V[1])/Sv2 Q1<-(Q[1]*V[1]+Q[2]*V[2])/Sv2 Q2<-(-Q[1]*V[2]+Q[2]*V[1])/Sv2 m1 <- -Eps; M1 <- 1+Eps m2 <- -Eps; M2 <- Eps if (max(P1,Q1)M1) { Out<-Inf return(Out) } if (max(P2,Q2)M2) { Out<-Inf return(Out) } if (P2*Q2<0) { T<- P1-(Q1-P1)/(Q2-P2)*P2 if (T>m1 && T -Eps0 && T<1+Eps0) { Tmp1<-A+T*V Tmp2<-min(max(T,0),1) Out<-list(Tmp1,Tmp2,0) } else { Tmp1<-A+T*V Tmp2<-min(max(T,0),1) Out<-list(Tmp1,Tmp2,1) } return(Out) } if (P1M1 || P2M2) { if (Q1M1 || Q2M2) { Out<-Inf return(Out) } T<-min(max(Q1,0),1) Tmp=A+T*V Out<-list(Tmp,T,1) return(Out) } T<-min(max(P1,0),1) Tmp<-A+T*V Out<-list(Tmp,T,1) return(Out) } if (P1> -Eps0 && P1<1+Eps0 && P2> -Eps0 && P2 < Eps0) { T<- P1 Tmp<- A+T*V Out<- list(Tmp, T, 0) return(Out) } if (Q1> -Eps0 && Q1<1+Eps0 && Q2> -Eps0 && Q2M1 || P2M2) { if (Q1M1 || Q2M2) { Out<-Inf return(Out) } T<-min(max(Q1,0),1) Tmp<-A+T*V Out<-list(Tmp,T,1) return(Out) } if (Q1M1 || Q2M2) { T<-min(max(P1,0),1) Tmp<-A+T*V Out<-list(Tmp,T,1) return(Out) } if (abs(P2)Eps) { QL<-Pt1 } Tmp<-Appendrow(QL,PL[(N1+1):N2,]) QL<- Tmp if (Norm(Pt2-Op(N2,PL))>Eps) { Tmp<-Appendrow(QL,Pt2) QL<- Tmp } HidariL<- QL Ms<- M2+1; Me<- M1 if (T1Eps) { Tmp<-Append(HidariL,P) HidariL<-Tmp } } Tmp<- Op(Nrow(HidariL),HidariL) if (Norm(Tmp-Pt1)>Eps) { Tmp<-Append(HidariL,Pt1) HidariL<-Tmp } MigiL<- QL Ms<- M2; Me<- M1+1 if (T1>T2-Eps) Me<- Me-4 for (Mm in Looprange(Me,Ms)) { M<- Me+Ms-Mm Tmp<- Op(Nrow(MigiL),MigiL) P<- Op(((M-1) %% 4)+1,Sikaku) if (Norm(Tmp-P)>Eps) { Tmp<-Appendrow(MigiL,P) MigiL<-Tmp } } Tmp<- Op(Nrow(MigiL),MigiL) if (Norm(Tmp-Pt1)>Eps) { Tmp<-Appendrow(MigiL,Pt1) MigiL<-Tmp } Out<- list(HidariL,MigiL) return(Out) } ################################### # 17.09.24 Eps Kyoukai<- function(...) { varargin<- list(...) Nargs<- length(varargin) Eps0<- 10^(-5) DataL<-list() for (I in 1:Nargs){ Tmp<- varargin[[I]] if (mode(Tmp)=="numeric"){ DataL<- Mixjoin(DataL,list(list(Tmp))) } if (mode(Tmp)=="list"){ if (mode(Tmp[[1]])!="list"){ DataL<- Mixjoin(DataL, list(Tmp)) } else{ DataL<-Mixjoin(DataL,Tmp) } } } Eps<- 10.0^(-4) #17.09.24 PLall<- list() Sflg<- 0 N<- length(DataL) for (I in 1:N){ Data<- Op(I, DataL) Tmp<- Op(length(Data),Data) if (mode(Tmp)=="numeric" && Nrow(Tmp)==1 && length(Tmp)>1){ Rg<-Tmp ; Nd<-length(Data)-1 } else{ if (mode(Tmp)=="character"){ Rg<- Tmp ; Nd<-length(Data)-1 } else{ Rg<- "c" ; Nd<-length(Data) } } for (J in Looprange(1,Nd)){ Tmp<- Op(J,Data) if (mode(Tmp)=="character"){ Rg<- Tmp next } Points<- Tmp P1<- Ptstart(Points) P2<- Ptend(Points) if (J==1){ PL<- Points Pfirst<- P1 Plast<- P2 if (Nd>=2){ Tmp<- Data[[2]] P<- Ptstart(Tmp) Q<- Ptend(Tmp) if (Norm(P2-P)>Eps && Norm(P2-Q)>Eps){ Tmp< Nrow(PL) PL<-PL[Tmp:1,] Pfirst<- Ptstart(PL) Plast<- Ptend(PL) } } } else{ if (Norm(P1-Plast)Eps){ Np<- Nrow(PL) if (Rg=="c"){ Tmp<- Appendrow(PL,Pfirst) PL<- Tmp } else if (Rg=="s"){ Tmp<- c(PL[1:Np,2],YMIN) Y<- min(Tmp)-1 P<- c(Plast[1],Y); Q<- c(Pfirst[1],Y) Tmp<- Appendrow(PL,P,Q,Pfirst) PL<- Tmp } else if (Rg=="n"){ Tmp<- c(PL[1:Np,2],YMAX) Y<-max(Tmp)+1 P<- c(Plast[1],Y); Q<- c(Pfirst[1],Y) Tmp<- Appendrow(PL,P,Q,Pfirst) PL<- Tmp } else if (Rg=="w"){ Tmp<- c(PL[1:Np,1],XMIN) X<- min(Tmp)-1 P<- c(X,Plast[2]); Q<- c(X,Pfirst[2]) Tmp<- Appendrow(PL,P,Q,Pfirst) PL<- Tmp } else if (Rg=="e"){ Tmp<- c(PL[1:Np,1],XMAX) X<- max(Tmp)+1 P<- c(X,Plast[2]); Q<- c(X,Pfirst[2]) Tmp<- Appendrow(PL,P,Q,Pfirst) PL<- Tmp } else if (mode(Rg)=="numeric" && Nrow(Rg)==1 && length(Rg)>1){ Tmp<- Kukeiwake(PL) Tmp1<- Op(1,Tmp) Tmp2<- Naigai(Rg,list(Tmp1)) if (Tmp2==c(1)){ PL<-Op(1,Tmp) } else{ PL<- Op(2,Tmp) } } } Tmp<- Ptstart(PL) for (J in 2:Nrow(PL)){ P<- Op(J,PL) Q<- Op(Nrow(Tmp),Tmp) if (Norm(P-Q)>Eps){ Tmp1<-Appendrow(Tmp,P) Tmp<-Tmp1 } } PL<-Tmp PLall<-Mixjoin(PLall,list(PL)) } if (length(PLall)==1 && Sflg==0){ Tmp<- Op(1,PLall) # Tmp<- Op(1,Tmp) if (Norm(Ptstart(Tmp)-Ptend(Tmp))>Eps0){ Tmp1<- Appendrow(Tmp,Ptstart(Tmp)) PLall<- list(Tmp1) } } return(PLall) } ###################################### Letter<-function(...) { ## Scaling is implemented varargin<-list(...) Nargs<-length(varargin) Irng<-c(seq(from=1,to=Nargs,by=3)) for (I in Irng) { Tmp<-varargin[[I]] P<- Doscaling(Tmp) X<-P[1] Y<-P[2] Houkou<-varargin[[I+1]] Mojiretu<-varargin[[I+2]] Hset<-Houkou Vhoko<-"c" if (length(grep("n",Hset))>0) { Vhoko<-"n"; Y<-Y+MEMORI } if (length(grep("s",Hset))>0) { Vhoko<-"s"; Y<-Y-MEMORI } Hhoko<-"c" if (length(grep("e",Hset))>0) { Hhoko<-"e"; X<-X+MEMORI } if (length(grep("w",Hset))>0) { Hhoko<-"w"; X<-X-MEMORI } Hoko<-paste(Vhoko,Hhoko,sep="") Suu<-"+-.0123456789" SuuL<-Suu J<-1; Dstr<-"" while (J<=nchar(Houkou)) { Tmp<-substring(Houkou,J,J) if (length(grep(Tmp,SuuL))>0) { if (Dstr=="") Hk<-substring(Houkou,J-1,J-1) Dstr<-paste(Dstr,Tmp,sep="") } else { if (Dstr!="") { Nmbr<-as.numeric(Dstr) D<-Nmbr*MEMORI if (Hk=="n") Y<-Y+D if (Hk=="s") Y<-Y-D if (Hk=="e") X<-X+D if (Hk=="w") X<-X-D Dstr<-"" } } J<-J+1 } if (Dstr!="") { Nmbr<-as.numeric(Dstr) D<-Nmbr*MEMORI; if (Hk=="n") Y<-Y+D if (Hk=="s") Y<-Y-D if (Hk=="e") X<-X+D if (Hk=="w") X<-X-D } CalcWidth(Hoko,Mojiretu) CalcHeight(Hoko,Mojiretu) cat("\\put(",file=Wfile,append=TRUE) Tmp1<- sprintf("%7.7f",X) # 11.07.19 Tmp2<- sprintf("%7.7f",Y) # 11.07.19 Str<-paste(Tmp1,",",Tmp2,sep="") cat(Str,file=Wfile,append=TRUE) Tmp<-"){\\hspace*{\\Width}" Str<-paste(Tmp,"\\raisebox{\\Height}{",Mojiretu,"}}%\n",sep="") cat(Str,file=Wfile,append=TRUE) cat("%\n",file=Wfile,append=TRUE) } } ###################################################### Letterrot<- function(...) { varargin<- list(...) P<- varargin[[1]] V<- varargin[[2]]; N<- 3 P<- Doscaling(P) V<- Doscaling(V) Tmov<- 0 Tmp<- varargin[[N]] if (mode(Tmp)=="numeric"){ Tmov<- Tmp; N<- N+1 } Nmov<- 0 Tmp<- varargin[[N]] if (mode(Tmp)=="numeric"){ Nmov<- Tmp; N<- N+1 } Mojiretu<- varargin[[N]] Tv<- 1/Norm(V)*V Nv<- c(-Tv[2],Tv[1]) P<- P+MEMORI*Tmov*Tv+MEMORI*Nmov*Nv Tmp<- acos(V[1]/Norm(V)) Theta<- round(Tmp*180/pi) if (V[2]>=0){ Units<- "" } else{ Units<- "units=-360," } Tmp<- paste("\\rotatebox[",Units,"origin=c]{",as.character(Theta),sep="") Tmp<- paste(Tmp,"}{",Mojiretu,"}",sep="") Letter(P,"c",Tmp) } ################################### # 10.12.04 Lineplot<-function(...) { varargin <- list(...) Nargs<-length(varargin) A<-varargin[[1]] if (is.numeric(A)) { Tmp<-length(A) if (Tmp>3) { B <- A[(Tmp/2+1):Tmp] A <- A[1:(Tmp/2)] Is <- 2 } else { B<-varargin[[2]] Is <- 3 } } else { B<-A[[2]] A<-A[[1]] Is <- 2 } Mag <- 100 ; Semi <- "" ## 10.12.04 for (I in Looprange(Is,Nargs)) { Tmp <- varargin[[I]] switch ( mode(Tmp), "numeric"= Mag <- Tmp, "character"= Semi <- Tmp ) } V<- Mag/Norm(B-A)*(B-A) ## 10.12.04 from here if (Semi=="") { Out<- Listplot(c(A-V,A+V)) } else if (Semi=="+") { Out<- Listplot(c(A,A+V)) } else { Out<- Listplot(c(A-V,A)) } ## 10.12.04 to here return(Out) } ################################ Listplot<-function(...) { varargin<-list(...); Z<-c(); for (I in 1:length(varargin)) { Data<-varargin[[I]]; if (mode(Data)=="numeric") { if (class(Data)=="numeric") { Tmp<-matrix(Data,nrow=2); Tmp<-t(Tmp); Z<-Appendrow(Z,Tmp) } else Z<-Appendrow(Z,Data) } else { for (J in 1:length(Data)) { Tmp<-Data[[J]]; Z<-Appendrow(Z,Tmp) } } } return(Z) } ############################## MakeBowdata <- function(PA,PB,H) { Eps <- 10^(-5) BOWSTART <<- PA BOWEND <<- PB D <- 1/2*Norm(PB-PA) R <- (H^2+D^2)/(2*H) A1 <- PA[1]; A2<-PA[2] B1 <- PB[1]; B2<-PB[2] if (abs(A2-B2)>Eps){ # x <- poly(0,"X") # y <- -(A1-B1)*x/(A2-B2)+(1/2)*(A1^2+A2^2-B1^2-B2^2)/(A2-B2) # Eq1 <- (A1-x)^2+(A2-y)^2-R^2 # Tmp <- coeff(Eq1) # C0 <- Tmp[1]; C1<-Tm[2]; C2<-Tmp[3] C0<- A1^2+(A2-(1/2)*(A1^2+A2^2-B1^2-B2^2)/(A2-B2))^2-R^2 C1<- -(A1+B1)*(A2^2+B2^2-2*A2*B2-2*A1*B1+A1^2+B1^2)/(A2-B2)^2 C2<- 1+(A1-B1)^2/(A2-B2)^2 Det <- sqrt(C1^2-4*C0*C2) Ansx1 <- (-C1+Det)/(2*C2) Ansx2 <- (-C1-Det)/(2*C2) Tmp <- -(A1-B1)*Ansx1/(A2-B2)+(1/2)*(A1^2+A2^2-B1^2-B2^2)/(A2-B2) PC <- c(Ansx1,Tmp) Tmp <--(A1-B1)*Ansx2/(A2-B2)+(1/2)*(A1^2+A2^2-B1^2-B2^2)/(A2-B2) PC2 <- c(Ansx2,Tmp) } else{ Tmp <- 0.5*(PA+PB) PC <- Tmp+c(0,R-H) # 11.06.02 PC2 <- Tmp-c(0,R-H) } VA <- PA-PC VB <- PB-PC if (VA[1]*VB[2]-VA[2]*VB[1]<0) { PC <- PC2 } AngA <- acos((PA[1]-PC[1])/R) if (PA[2]-PC[2]<0){ AngA <- -AngA } AngB <- acos((PB[1]-PC[1])/R) if (PB[2]-PC[2]<0){ AngB <- -AngB } if (AngA>AngB) { AngB <- AngB+2*pi } Out <- list(PC,R,AngA,AngB) return(Out) } #################################################### MakeCurves<-function(...){ ## Scaling is implemented varargin<-list(...) Figdata<-varargin[[1]] if (class(Figdata)=="numeric"){ Figdata<-matrix(Figdata,nrow=1) } Ptout<-1 if (length(varargin)>=2) Ptout<-varargin[[2]] Eps<-10.0^(-6) IndM<-Dataindex(Figdata) Atos<-c() for (Nd in 1:Nrow(IndM)){ Tmp<-IndM[Nd,] Motos<-Figdata[Tmp[1]:Tmp[2],] All<-Nrow(Motos) if (Nrow(Motos)==1){ if (InWindow(Motos)=="o"){ next } Tmp1<- as.numeric(Motos) if (Ptout==1){ Drwpt(Tmp1) } else{ Tmp1<- Doscaling(Tmp1) Atos<-Appendrow(Atos,c(Inf,Inf),Tmp1) next } } Crv<-c() for (I in Looprange(2,All)){ P<- Op(I-1,Motos) Q<- Op(I,Motos) Snbn<-MeetWindow(P,Q) if (length(Snbn)==0){ if (length(Crv)>0){ Atos<-Appendrow(Atos,c(Inf,Inf),Doscaling(Crv)) Crv<-c() } } else{ if(Norm(Snbn[1,]-Snbn[2,])=2) { Atos<-Appendrow(Atos,c(Inf,Inf),Doscaling(Crv)) } } Outdata<-Atos[2:Nrow(Atos),] if (class(Outdata)=="numeric") { Outdata<-matrix(Outdata,nrow=1) } return(Outdata) } ###################################### Makehasen<- function(Figdata,Sen,Gap,Ptn) { Eps<- 10.0^(-6) Clist<- MakeCurves(Figdata) DinM<- Dataindex(Clist) for (N in Looprange(1,Nrow(DinM))){ Tmp<- DinM[N,] Data<- Clist[Tmp[1]:Tmp[2],] Dtall<- Nrow(Data) Len<- 0 Lenlist<- c(0) for (I in Looprange(2,Dtall)){ Len<- Len+Norm(Data[I,]-Data[I-1,]) Lenlist<- c(Lenlist,Len) } Lenall<- Lenlist[Dtall] if (Lenall==0){ next } Kari<- (Sen+Gap)*0.1 Naga<- Sen*0.1 Tobi<- Gap*0.1 if (Norm(Data[1,]-Data[Dtall,])=Lenlist[J]-Eps){ if (J==Dtall){ break } J<- J+1 } Hajime<- J-1 J<- Hajime while (Len+Naga>Lenlist[J]-Eps){ if (J==Dtall){ break } J<- J+1 } Owari<- J-1 T<- (Len-Lenlist[Hajime]) T<- T/(Lenlist[Hajime+1]-Lenlist[Hajime]) P<- Data[Hajime,]+T*(Data[Hajime+1,]-Data[Hajime,]) X<- as.character(round(MilliIn*P[1])) Y<- as.character(-round(MilliIn*P[2])) Str<- paste("\\special{pa ",X," ",Y,"}",sep="") cat(Str,file=Wfile,append=TRUE) Mojisu<- Mojisu+nchar(Str) for (J in Looprange(Hajime+1,Owari)){ P<- Data[J,] X<- as.character(round(MilliIn*P[1])) Y<- as.character(-round(MilliIn*P[2])) Str<- paste("\\special{pa ",X," ",Y,"}",sep="") cat(Str,file=Wfile,append=TRUE) Mojisu<- Mojisu+nchar(Str) } T<- (Len+Naga-Lenlist[Owari]) T<- T/(Lenlist[Owari+1]-Lenlist[Owari]) P<- Data[Owari,]+T*(Data[Owari+1,]-Data[Owari,]) X<- as.character(round(MilliIn*P[1])) Y<- as.character(-round(MilliIn*P[2])) Str1<- paste("\\special{pa ",X," ",Y,"}",sep="") Str2<- "\\special{fp}" cat(Str1,file=Wfile,append=TRUE) cat(Str2,file=Wfile,append=TRUE) Mojisu<- Mojisu+nchar(Str1)+nchar(Str2) if (Mojisu>80){ cat("%\n",file=Wfile,append=TRUE) Mojisu<- 0 } } } cat("%\n%\n",file=Wfile,append=TRUE); } ###################################### Makeliststr<- function(L) { Out="list(" for (I in 1:length(L)){ Dt<- L[[I]] if (mode(Dt)=="numeric"){ if (length(Dt)==1){ Dts<- as.character(Dt) } else{ Dts<- "c(" for (J in Looprange(1,Nrow(Dt))){ for (K in 1:ncol(Dt)){ Dts<- paste(Dts,as.character(Dt[J,K]),sep="") if (K< ncol(Dt)){ Dts<- paste(Dts,",",sep="") } } if (JEps){ if (Member(Ptn,PtnL)){ if (abs(Te-Ts)>Eps){ if (Nrow(GL)>0){ Tmp<- Mixjoin(Out, list(GL)) Out<- Tmp } GL<- Listplot(P,Q) } else{ Tmp <- Appendrow(GL, Q) GL<- Tmp } Te<- Op(1,TenQ) } } } if (Nrow(GL)>0){ Tmp<- Mixjoin(Out, list(GL)) Out<- Tmp } return(Out) } ############################################# Mawarikomi<- function(...) { varargin<- list(...) haba<- "10cm" Nargs<- length(varargin) if (Nargs>0){ haba<- varargin[[1]] } cat("\\begin{mawarikomi}%\n",file="",append=TRUE) cat("%<1>[5](0,0)%\n",file="",append=TRUE) Str<- paste("{",haba,"}{%\n",sep="") cat(Str,file="",append=TRUE) cat("}%\n",file="",append=TRUE) cat("\\end{mawarikomi}",file="",append=TRUE) } ############################################## MeetWindow<-function(PA,PB) { if (InWindow(PA)=="i" && InWindow(PB)=="i") { R<-Appendrow(PA,PB) return(R) }; Horner<-function(n,t) { PT<-(1-t)*PA+t*PB; return(PT[n]) } Eps<-10.0^(-6); Txm<-(-1); TxM<-(-1); Tym<-(-1); TyM<-(-1); if (PA[1]!=PB[1]) { Txm<-(XMIN-PA[1])/(PB[1]-PA[1]); TxM<-(XMAX-PA[1])/(PB[1]-PA[1]); } if (PA[2]!=PB[2]) { Tym<-(YMIN-PA[2])/(PB[2]-PA[2]); TyM<-(YMAX-PA[2])/(PB[2]-PA[2]); } Tmp<-Horner(2,Txm); if (TmpYMAX+Eps) { Txm<-(-1); } Tmp<-Horner(2,TxM); if (TmpYMAX+Eps) { TxM<-(-1) } Tmp<-Horner(1,Tym); if (TmpXMAX+Eps) { Tym<--1 } Tmp<-Horner(1,TyM); if (TmpXMAX+Eps) { TyM<--1 } Tans<-sort(c(Txm,TxM,Tym,TyM)); Tmp<-c(); for (I in 1:length(Tans)) { Tmp1<-Tans[I]; if (Tmp1>-Eps && Tmp1<1+Eps) { if (length(Tmp)==0) { Tmp<-c(Tmp1); } else { if (abs(Tmp[length(Tmp)]-Tmp1)>Eps) { Tmp<-c(Tmp,Tmp1) } } } } Tans<-Tmp; if (length(Tans)==0) { R<-c(); return(R); } if (length(Tans)==1) { Ten1<-Horner(1:2,Tans[1]); if (InWindow(PA)=="i") { R<-Appendrow(PA,Ten1) return(R) } else { R<-Appendrow(Ten1,PB) return(R) } } Ten1<-Horner(1:2,Tans[1]) Ten2<-Horner(1:2,Tans[2]) R<-Appendrow(Ten1,Ten2) return(R) } ######################################### # New 10.03.21 Mixjoin<-function(...) { varargin<-list(...) Nargs<- length(varargin) M<- list() for (I in 1:Nargs) { Tmp<-varargin[[I]] if (length(Tmp)==0) next if (Mixtype(Tmp)==1) { Tmp<-list(Tmp) } if (length(M)==0){ M <- Tmp } else{ M<- c(M,Tmp) } } return(M) } ################################# Mixlength<- function(PL){ if (length(PL)==0){ return(0) } if (Mixtype(PL)==1){ Out<- Nrow(PL) } else{ Out<- length(PL) } return(Out) } ########################################### Mixtype<- function(D) { if (mode(D)!="list") return(1) for (I in 1:length(D)) { Tmp<- D[[I]] if (mode(Tmp)=="list") return(3) } return(2) } ########################################### Naigai<- function(A,Bdy) { V<- c(1,1) Call<-length(Bdy) KL<- KoutenList(A,V,Bdy) Ptn<- seq(1,1,length=Call) for (K in Looprange(1,length(KL))) { Ten<- Op(K,KL) T<- Op(1,Ten); NC<- Op(4,Ten) if (T<0) { Tmp<- (Ptn[NC]+1) %% 2 Ptn[NC]<- Tmp } } return(Ptn) } ######################################## Nearestpt<-function(...) { varargin<-list(...) Nargs<-length(varargin) PL1<-varargin[[1]] if (!is.matrix(PL1)) { Tmp<-matrix(PL1); PL1<-t(Tmp) } if (Nrow(PL1)==1) Flg=0 else Flg=1 Eps<-10.0^(-6) PL<-varargin[[2]] Ans<-list(PL1[1,],1,PL[1,],1,Norm(PL1[1,]-PL[1,])) for (N in 1:Nrow(PL1)) { PA<-PL1[N,] Pm<-PL[1,] Im<-1 Sm<-Norm(Pm-PA) for (I in 1:(Nrow(PL)-1)) { A1<-PL[I,1]; A2<-PL[I,2] B1<-PL[I+1,1]; B2<-PL[I+1,2] V1<-B1-A1; V2<-B2-A2 X1<-PA[1]; X2<-PA[2] Tmp<-V2^2+V1^2 if (abs(Tmp)1+Eps) { P<-c(B1,B2) } else { P<-c(A1+T*V1,A2+T*V2) } } S<-Norm(P-PA) if (S1){ for(N in 2:Nargs){ Tmp<- varargin[[N]] Tmp1<- strsplit(Tmp,"=",fixed=TRUE) Tmp1<- Tmp1[[1]] if(length(Tmp1)>1){ Creator<- Tmp1[2] Cflg<- 1 } else{ Unitstr<- Tmp Bflg<- 1 } } } Recentf<- "" Fv<- list.files() Nv<- grep("\\.r$", Fv) Rfiles<- Fv[Nv] # if(length(Rfiles)>0){ # Finfo<- file.info(Rfiles) # Tmp1<- as.POSIXlt(Finfo$ctime) # Tmp2<- order(Tmp1,decreasing=TRUE) # Recentf<- Rfiles[Tmp2[1]] # } # Tmp<- sprintf("%s",Sys.time()) StrW<- paste("%%% ",File," ",Tmp,sep="") StrC<- paste("%%% ",Creator,sep="") if(Cflg==0){ # if(nchar(Recentf)>0){ # Tmp1<- file.info(Recentf) # Tmp2<- sprintf("%s",Tmp1$ctime) # StrC<- paste(StrC,Recentf," ",Tmp2,sep="") # } } # 2013.12.15 upto cat(StrW,"\n",file=Wfile) cat(StrC,"\n",file=Wfile,append=TRUE) if(Bflg==1){ Beginpicture(Unitstr) } } ######################################### Openpar<- function(...) { varargin<- list(...) Nargs<- length(varargin) Tmp<- varargin[[1]] Tmp1<- substr(Tmp,1,1) if (Tmp1=="\\"){ Namestr<- Tmp N<- 2 } else{ Namestr<- "\\tmp" N<- 1 } Habastr<- varargin[[N]] if (Nargs>N){ Posstr<- paste("[",varargin[[N+1]],"]",sep="") } else{ Posstr<- "[c]" } Openphr(Namestr) S<- paste("\\begin{minipage}",Posstr,"{",Habastr,"}%\n",sep="") cat(S,file=Wfile,append=TRUE) } ################################### Openphr<- function(Str) { S<- paste("\\def",Str,"{%\n",sep="") cat(S,file=Wfile,append=TRUE) } ##################################### Ovalbox<- function(...) { varargin<- list(...) Nargs<- length(varargin) Pos<- varargin[[1]] Dr<- varargin[[2]] StrV<- varargin[[3]] R<- 0.2 NDflg<- 0 for (I in Looprange(4,Nargs)){ Tmp<- varargin[[I]] if (mode(Tmp)=="numeric"){ R<- Tmp } else{ if (substr(Tmp,1,1)=="-"){ NDflg<- 1 Tmp1<- substr(Tmp,2,nchar(Tmp)) Cmdstr<- chartr("*","G",Tmp1) } } } Xr<- c(XMIN,XMAX) Yr<- c(YMIN,YMAX) Uv<- 0.6; Uh<- 0.8 N<- nchar(StrV) W<- Uh;H<- Uv*N Setwindow(c(-W/2,W/2),c(-H,0)) G<- Ovaldata(c(0,-H/2),W/2,H/2,R) Openphr("\\ketpictmp") Beginpicture("1cm") if (NDflg==0){ Drwline(G) } else{ eval(parse(text=Cmdstr)) } for (I in Looprange(1,N)){ Letter(c(0,Uv/2-Uv*I),"c",Op(I,StrV)) } Endpicture(0) Closephr() Setwindow(Xr,Yr) Letter(Pos,Dr,"\\ketpictmp") } ########################################## Ovaldata<- function(...) #17.09.11 { varargin<- list(...) Nargs<- length(varargin) if (Nargs==1){ Eps<- 1.0*10^(-4) C<- c((XMIN+XMAX)/2,(YMIN+YMAX)/2) Dx<- XMAX-C(1)-Eps Dy<- YMAX-C(2)-Eps N<- 1 } else{ C<- varargin[[1]] Dx<- varargin[[2]] Dy<- varargin[[3]] N<- 4 } Rc<- 0.2 if (N<=Nargs){ #15.11.15 Rc<- varargin[[N]]*Rc #15.11.15 } Out<- c() P<- C+c(Dx-Rc,Dy-Rc) Tmp1<- Circledata(P,Rc,"R=c(0,pi/2)","N=10") Tmp2<- Listplot(C+c(Dx-Rc,Dy),C+c(0,Dy)) Tmp3<- Listplot(C+c(Dx,0),C+c(Dx,Dy-Rc)) G<- Joincrvs(Tmp3,Tmp1,Tmp2) Tmp<- Reflectdata(G,c(C,C+c(0,1))) G<- Joincrvs(G,Tmp) Tmp<- Reflectdata(G,c(C,C+c(1,0))) Out<- Joincrvs(G,Tmp) } ######################################### Paramark<- function(...) { varargin<- list(...) Nargs<- length(varargin) PA<- varargin[[1]] PB<- varargin[[2]] PC<- varargin[[3]] R<- 0.5 if (Nargs>=4){ R<- varargin[[4]]*R } U<- R*(PA-PB)/Norm(PA-PB) V<- R*(PC-PB)/Norm(PC-PB) if (Crossprod(PA-PB,PC-PB)!=0){ P<- Listplot(c(PB+U,PB+U+V,PB+V)) } else{ P<- c() } } ########################################### Paramoncrv<-function(...) { varargin<-list(...) Nargs<-length(varargin) Eps<-10^(-8) P<-varargin[[1]] Gdata<-varargin[[Nargs]] if (Nrow(P)>1) { Tmp<-P; P<-Gdata; Gdata<-Tmp } if (Nargs==2) { Tmp<-Nearestpt(P,Gdata) Out<-Tmp[[2]] return(Out) } N<-varargin[[2]] PtL<-Gdata if (N==Nrow(PtL)) { Out<-N } else { Pa<-Ptcrv(N,PtL) Pb<-Ptcrv(N+1,PtL) V<-Pb-Pa W<-P-Pa D2<-Norm(V)^2 if (D20) { E<-sort(E) E0 && Op(Nrow(P),P)!=c(Inf,Inf)) { Pa<- c(Inf,Inf) } } if (t-E[Ke]>Eps) { if (Fnflg==0) { Tmp<- eval(parse(text=Str)) Pa<- Tmp } else { } Ke<-Ke+1 } if (length(Pa)>0) { if (Pa[1]==Inf) { Tmp<-Appendrow(P,Pa) P<-Tmp } else { if (Nrow(P)==0) { Tmp<- Appendrow(P,Pa) P<-Tmp } else { Tmp<- Op(Nrow(P),P) if (Tmp[1]==Inf) { Tmp<- Appendrow(P,Pa) P<- Tmp } else { if (Norm(Tmp-Pa)B+Eps){ Npt<- Numptcrv(PkL) Out1<- Partcrv(A,Npt,PkL) Out2<- Partcrv(1,B,PkL) Tmp<- Ptstart(PkL)-Ptend(PkL) if (Norm(Tmp)Ie+Eps){ P<- (1-B+Ie)*PkL[Ie,]+(B-Ie)*PkL[Ie+1,] PL<- Appendrow(PL,P) } Ans<- PL return(Ans) } Tmp<- Nearestpt(A,PkL) Ta<- Op(2,Tmp) Tmp<- Nearestpt(B,PkL) Tb<- Op(2,Tmp) Ans<- Partcrv(Ta,Tb,PkL) } ########################################## # 13.05.03 Partframe<- function(Tb,St,Ed) { G<- Dividetable(Tb) Gw<- G[[1]] Gt<- G[[2]] Gy<- G[[3]] Gwt<- Tb[[4]] Gwy<- Tb[[5]] Gat<- c(list(Gwt[[1]]),Gt,list(Gwt[[2]])) Gay<- c(list(Gwy[[1]]),Gy,list(Gwy[[2]])) Tmp1<- Ptstart(Gat[[St[1]]]) Tmp2<- Ptstart(Gay[[St[2]]]) Ps<- c(Tmp1[1],Tmp2[2]) Tmp1<- Ptstart(Gat[[Ed[1]]]) Tmp2<- Ptstart(Gay[[Ed[2]]]) Pe<- c(Tmp1[1],Tmp2[2]) Pars<- Paramoncrv(Ps,Gw) Pare<- Paramoncrv(Pe,Gw) if(Pars0){ E<-sort(E) E0){ Tmp<-eval(parse(text=Exfun)) if (abs(Tmp)0 && P[Nrow(P),]!=c(Inf,Inf)){ Pa<- c(Inf,Inf) } } if (x-E[Ke]>Eps){ Tmp<- eval(parse(text=Str)) Pa<- c(x,Tmp) Ke<-Ke+1 } if (length(Pa)>0){ if (Pa[1]==Inf){ Tmp<-Appendrow(P,Pa) P<-Tmp } else{ if (Nrow(P)==0){ Tmp<- Appendrow(P,Pa) P<-Tmp } else{ Tmp<- P[Nrow(P),] if (Tmp[1]==Inf){ Tmp<- Appendrow(P,Pa) P<- Tmp } else{ if (Norm(Tmp-Pa)1) { Tmp<-T; T<-Gdata; Gdata<-Tmp } PtL<-Gdata N<-trunc(T+Eps); S<-max(T-N,0); if (N==Nrow(PtL)) { Out<-PtL[N,] } else { Pa<-PtL[N,] Pb<-PtL[N+1,] Out<-(1-S)*Pa+S*Pb } return(Out) } ############################################## # 10.11.20 # 13.05.03 Inf Pointdata<-function(...) { varargin<-list(...) Nargs<-length(varargin) PL<- list() for (I in Looprange(1,Nargs)){ # 10.11.20 DL<-varargin[[I]] DL<- Flattenlist(DL) # 10.11.20 from here for (J in Looprange(1,length(DL))){ Dt<- DL[[J]] if(is.matrix(Dt)|| is.data.frame(Dt)){ for (K in 1:nrow(Dt)){ Tmp<- as.numeric(Dt[K,]) if(Tmp[1]1){ Tmp1<- nchar(Tmp[1]) Clm<- c(Clm,Tmp1) } } Nrg<- 0 for (I in seq(length(Clm),1,by=-1)){ Tmp<- Clm[I] Tmp1<- length(Clm)-I Nrg<- Nrg+Tmp*26^Tmp1 } CoL<- Nrg } Nc<- length(TbL[[3]])+1 K<- 1 Dpos<- varargin[[3]] for (I in Looprange(4,Nargs)){ if (I-3>Nc){ break } Dt<- varargin[[I]] if (mode(Dt)!="list"){ Putcell(TbL,CoL,K,Dpos,Dt) # 2011.03.02 K<- K+1 } else{ N<- length(Dt) Str<- Dt[[N]] Rrng<- c(K,K+1) Pos<- Dpos for (J in Looprange(1,N-1)){ Tmp<- Dt[[J]] if (mode(Tmp)=="numeric"){ Rrng<- c(K,K+Tmp) } if (mode(Tmp)=="character"){ Pos<- Tmp } } Putcell(TbL,CoL,Rrng,Pos,Str) K<- Crng[2] } } } Putcol<- function(...) { PutcoL(...) } PutcoLexpr<- function(...) { varargin<- list(...) Nargs<- length(varargin) TbL<- varargin[[1]] if (mode(TbL)!="list"){ return("Tabledata missing") } Ag<- varargin[[2]] if (mode(Ag)=="numeric"){ CoL<- Ag } else{ Alpha<- "-ABCDEFGHIJKLMNOPQRSTUVWXYZ" Clm<- c() for (I in Looprange(1,nchar(Ag))){ C<- substr(Ag,I,I) C<- toupper(C) Tmp<- strsplit(Alpha,C) Tmp<- Tmp[[1]] if (length(Tmp)>1){ Tmp1<- nchar(Tmp[1]) Clm<- c(Clm,Tmp1) } } Nrg<- 0 for (I in seq(length(Clm),1,by=-1)){ Tmp<- Clm[I] Tmp1<- length(Clm)-I Nrg<- Nrg+Tmp*26^Tmp1 } CoL<- Nrg } Nc<- length(TbL[[3]])+1 K<- 1 Dpos<- varargin[[3]] for (I in Looprange(4,Nargs)){ if (I-3>Nc){ break } Dt<- varargin[[I]] if (mode(Dt)!="list"){ Dt<- paste("$",Dt,"$",sep="") Putcell(TbL,CoL,K,Dpos,Dt) # 2011.03.02 K<- K+1 } else{ N<- length(Dt) Str<- paste("$",Dt[[N]],"$",sep="") Rrng<- c(K,K+1) Pos<- Dpos for (J in Looprange(1,N-1)){ Tmp<- Dt[[J]] if (mode(Tmp)=="numeric"){ Rrng<- c(K,K+Tmp) } if (mode(Tmp)=="character"){ Pos<- Tmp } } Putcell(TbL,CoL,Rrng,Pos,Str) K<- Crng[2] } } } Putcolexpr<- function(...) { PutcoLexpr(...) } ##################################################### PutcoLstr<- function(...) { varargin<- list(...) Nargs<- length(varargin) Tb<- varargin[[1]] Nr<- varargin[[2]] Pos<- varargin[[3]] Str<- varargin[[4]] Sep<- "" if (Nargs>4){ Sep<- varargin[[5]] } if (nchar(Sep)==0){ for (I in Looprange(1,nchar(Str))){ Tmp<- substr(Str,I,I) Putcell(Tb,Nr,I,Pos,Tmp) } } else{ Ltr<- "" K<- 1 for (I in Looprange(1,length(Str))){ Tmp<- substr(Str,I,I) if (Tmp==Sep){ Putcell(Tb,Nr,K,Pos,Ltr) K<- K+1 Ltr<- "" } else{ Ltr<- paste(Ltr,Tmp,sep="") } } if (nchar(Ltr)>0){ Putcell(Tb,Nr,K,Pos,Ltr) } } } ############################################# Putrow<- function(...) { varargin<- list(...) Nargs<- length(varargin) TbL<- varargin[[1]] if (mode(TbL)!="list"){ return("Tabledata missing") } Row<- varargin[[2]] Nr<- length(TbL[[2]])+1 K<- 1 Dpos<- varargin[[3]] for (I in Looprange(4,Nargs)){ if (I-3>Nr){ break; } Dt<- varargin[[I]] if (mode(Dt)!="list"){ Putcell(TbL,K,Row,Dpos,Dt) # 110308 K<- K+1 } else{ N<- length(Dt) Str<- Dt[[N]] Crng<- c(K,K+1) Pos<- Dpos for (J in Looprange(1,N-1)){ Tmp<- Dt[[J]] if (mode(Tmp)=="numeric"){ Crng<- c(K,K+Tmp) } if (mode(Tmp)=="character"){ Pos<- Tmp } } Putcell(TbL,Crng,Row,Pos,Str) K<- Crng[2] } } } Putrowexpr<- function(...) { varargin<- list(...) Nargs<- length(varargin) TbL<- varargin[[1]] if (mode(TbL)!="list"){ return("Tabledata missing") } Row<- varargin[[2]] Nr<- length(TbL[[2]])+1 K<- 1 Dpos<- varargin[[3]] for (I in Looprange(4,Nargs)){ if (I-3>Nr){ break; } Dt<- varargin[[I]] if (mode(Dt)!="list"){ Dt<- paste("$",Dt,"$",sep="") Putcell(TbL,K,Row,Dpos,Dt) #110308 K<- K+1 } else{ N<- length(Dt) Str<- paste("$",Dt[[N]],"$",sep="") Crng<- c(K,K+1) Pos<- Dpos for (J in Looprange(1,N-1)){ Tmp<- Dt[[J]] if (mode(Tmp)=="numeric"){ Crng<- c(K,K+Tmp) } if (mode(Tmp)=="character"){ Pos<- Tmp } } Putcell(TbL,Crng,Row,Pos,Str) K<- Crng[2] } } } #################################################### Putrowstr<- function(...) { varargin<- list(...) Nargs<- length(varargin) Tb<- varargin[[1]] Nr<- varargin[[2]] Pos<- varargin[[3]] Str<- varargin[[4]] Sep<- "" if (Nargs>4){ Sep<- varargin[[5]] } if (nchar(Sep)==0){ for (I in Looprange(1,nchar(Str))){ Tmp<- substr(Str,I,I) Putcell(Tb,I,Nr,Pos,Tmp) } } else{ Ltr<- "" K<- 1 for (I in Looprange(1,length(Str))){ Tmp<- substr(Str,I,I) if (Tmp==Sep){ Putcell(Tb,K,Nr,Pos,Ltr) K<- K+1 Ltr<- "" } else{ Ltr<- paste(Ltr,Tmp,sep="") } } if (nchar(Ltr)>0){ Putcell(Tb,K,Nr,Pos,Ltr) } } } ############################################ # 11.05.28 Ratiocmyk<- function(Color) { if(is.numeric(Color)){ return(Color) } R<- switch(Color, greenyellow=c(0.15,0,0.69,0), yellow=c(0,0,1,0), goldenrod=c(0,0.1,0.84,0), dandelion=c(0,0.29,0.84,0), apricot=c(0,0.32,0.52,0), peach=c(0,0.5,0.7,0), melon=c(0,0.46,0.5,0), yelloworange=c(0,0.42,1,0), orange=c(0,0.61,0.87,0), burntorange=c(0,0.51,1,0), bittersweet=c(0,0.75,1,0.24), redorange=c(0,0.77,0.87,0), mahogany=c(0,0.85,0.87,0.35), maroon=c(0,0.87,0.68,0.32), brickred=c(0,0.89,0.94,0.28), red=c(0,1,1,0), orangered=c(0,1,0.5,0), rubinered=c(0,1,0.13,0), wildstrawberry=c(0,0.96,0.39,0), salmon=c(0,0.53,0.38,0), carnationpink=c(0,0.63,0,0), magenta=c(0,1,0,0), violetred=c(0,0.81,0,0), rhodamine=c(0,0.82,0,0), mulberry=c(0.34,0.9,0,0.02), redviolet=c(0.07,0.9,0,0.34), fuchsia=c(0.47,0.91,0,0.08), lavender=c(0,0.48,0,0), thistle=c(0.12,0.59,0,0), orchid=c(0.32,0.64,0,0), darkorchid=c(0.4,0.8,0.2,0), purple=c(0.45,0.86,0,0), plum=c(0.5,1,0,0), violet=c(0.79,0.88,0,0), royalpurple=c(0.75,0.9,0,0), blueviolet=c(0.86,0.91,0,0.04), periwinkle=c(0.57,0.55,0,0), cadetblue=c(0.62,0.57,0.23,0), cornflowerblue=c(0.65,0.13,0,0), midnightblue=c(0.98,0.13,0,0.43), navyblue=c(0.94,0.54,0,0), royalblue=c(1,0.5,0,0), blue=c(1,1,0,0), cerulean=c(0.94,0.11,0,0), cyan=c(1,0,0,0), processblue=c(0.96,0,0,0), skyblue=c(0.62,0,0.12,0), turquoise=c(0.85,0,0.2,0), tealblue=c(0.86,0,0.34,0.02), aquamarine=c(0.82,0,0.3,0), bluegreen=c(0.85,0,0.33,0), emerald=c(1,0,0.5,0), junglegreen=c(0.99,0,0.52,0), seagreen=c(0.69,0,0.5,0), green=c(1,0,1,0), forestgreen=c(0.91,0,0.88,0.12), pinegreen=c(0.92,0,0.59,0.25), limegreen=c(0.5,0,1,0), yellowgreen=c(0.44,0,0.74,0), springgreen=c(0.26,0,0.76,0), olivegreen=c(0.64,0,0.95,0.4), rawsienna=c(0,0.72,1,0.45), sepia=c(0,0.83,1,0.7), brown=c(0,0.81,1,0.6), tan=c(0.14,0.42,0.56,0), gray=c(0,0,0,0.5), black=c(0,0,0,1), white=c(0,0,0,0) ) if(length(R)<4){ print("No color") return(c()) } return(R) } ############################################ # 11.01.07 Readtextdata<- function(...) { varargin<- list(...) OutL<- list() Nargs<- length(varargin) Fname<- varargin[[1]] Tmp<- readLines(Fname,n=1) if (length(grep("\t",Tmp))>0){ Sep<- "\t" } else if (length(grep(",",Tmp))>0){ Sep<- "," } else{ Sep<- " " } Hajime<- c(1,1) Owari<- c(Inf,Inf) C<- Inf R<- Inf Rna<- FALSE Cna<- TRUE Mat<- FALSE Num<- TRUE D<- -Inf Flg<- 0 for (I in Looprange(2,Nargs)){ Tmp<- varargin[[I]] if (mode(Tmp)=="numeric"){ if (Flg==0){ Hajime<- Tmp Flg<- 1 } else{ Owari<- Tmp } } else{ eval(parse(text=Tmp)) } } Tmp<- Hajime+c(R-1,C-1) Owari<- c(min(Owari[1],Tmp[1]),min(Owari[2],Tmp[2])) if (Cna){ Df<- read.table(Fname,sep=Sep,header=TRUE,,stringsAsFactors=FALSE) } else{ Df<- read.table(Fname,sep=Sep,header=FALSE,,stringsAsFactors=FALSE) Nv<- c(1:ncol(Df)) colnames(Df)<- Nv } if (Rna){ rownames(Df)<-Df[,1] Hajime<- Hajime+c(0,1) } if (Mat){ M<- as.matrix(Df) Tmp1<- min(Owari[1],nrow(M)) Tmp2<- min(Owari[2],ncol(M)) Out<- as.matrix(M[Hajime[1]:Tmp1,Hajime[2]:Tmp2]) if (Num){ Tmp1<- as.numeric(Out) Out<- matrix(Tmp1,nrow=nrow(Out)) } } else{ Tmp1<- min(Owari[1],nrow(Df)) Tmp2<- min(Owari[2],ncol(Df)) Out<- Df[Hajime[1]:Tmp1,Hajime[2]:Tmp2] } if (D!=-Inf){ # 11.01.20 v2 Tmp<- ncol(Out) # 11.01.07 Tmp1<- rep(Inf,Tmp) Out[Out[,1]<=D,]<- Tmp1 # 11.01.07 } return(Out) } ################################## Reflectdata<- function(...) { varargin<- list(...) Nargs<- length(varargin) Eps<- 10^(-8) ML<- varargin[[1]] if (Mixtype(ML)==1){ ML<- list(ML) } if (Nargs==1){ PtA<- c(0,0); PtB<- PtA } else{ Pts<- varargin[[2]] if (length(Pts)==2){ PtA<- Pts; PtB<- PtA } else{ PtA<- Pts[1:2]; PtB<- Pts[3:4] } } OutL<- list() for (N in Looprange(1,length(ML))){ GL<- Op(N,ML) Out<- c() for (I in Looprange(1,Nrow(GL))){ if(is.matrix(GL)){ # 10.12.07 Tmp<- GL[I,] } else{ Tmp<- GL } X1<- Tmp[1] Y1<- Tmp[2] if (X1==Inf){ X2<- X1 Y2<- Y1 } else{ if (Norm(PtA-PtB)0){ Str=paste(Str,",",sep="") } if(length(Pt)<3){ Str=paste(Str,sprintf("[%5.4f,%5.4f]",Pt[1],Pt[2]),sep="") } else{ Str=paste(Str,sprintf("[%5.4f,%5.4f,%5.4f]",Pt[1],Pt[2],Pt[3]),sep="") } if(nchar(Str)>80){ cat("[",Str,"]//","\n",sep="",file=Fname,append=TRUE) Str="" } } if(nchar(Str)>0){ cat("[",Str,"]//","\n",sep="",file=Fname,append=TRUE) } if((N==Nargs-1) & (K==length(Gdata)) & (J==length(GL))){ # cat("end////","\n",sep="",file=Fname,append=TRUE) cat("end//","\n",sep="",file=Fname,append=TRUE) } else{ cat("end//","\n",sep="",file=Fname,append=TRUE) } } } } cat("//","\n",sep="",file=Fname,append=TRUE) # 15.11.05 } ########################################## # 2015.10.23 ReadOutData<- function(...){ varargin<- list(...) Nargs<- length(varargin) Fname=varargin[[1]] cmdall=readLines(Fname) cmdall=gsub("//","",cmdall,fixed=TRUE) varname=cmdall[1] outdt=list() varL=c() ptL=list() flg=0 for(cmd in cmdall){ if(nchar(cmd)>0){ if((cmd=="start") | cmd=="end" | substring(cmd,1,1)=="["){ if(cmd=="start"){ pts=c() } if(cmd=="end"){ ptL=c(ptL,list(pts)) } if(substring(cmd,1,1)=="["){ tmp1=paste(",",substring(cmd,2,nchar(cmd)-1),sep="") tmp1=strsplit(tmp1,"]",fixed=TRUE) tmp1=tmp1[[1]] tmp1=gsub(",[","c(",tmp1,fixed=TRUE) for(st in tmp1){ tmp=eval(parse(text=paste(st,")",sep=""))) pts=rbind(pts,tmp) } row.names(pts)=1:nrow(pts) } } else{ varname=cmd varL=c(varL,varname) if(flg==0){ # 17.10.07from flg=1 }else{ outdt=c(outdt,list(ptL)) } # 17.10.07upto ptL=c() } } } outdt=c(outdt,list(ptL)) # 17.10.07 names(outdt)=varL for(var in varL){ tmp=paste(var,"<<- outdt$",var,sep="") eval(parse(text=tmp)) } # print(varL) outdt } #################################################### Rotatedata<- function(..., deg=FALSE) { varargin<- list(...) Nargs<- length(varargin) Eps<- 10^(-8) ML<- varargin[[1]] if (Mixtype(ML)==1){ ML<- list(ML) } Theta<- varargin[[2]] if (deg) Theta<- Theta*pi/180 # 10.12.07 if (Nargs==2){ Pt<- c(0,0) } else{ Pt<- varargin[[3]] } Cx<- Pt[1]; Cy<- Pt[2] OutL<- c() for (N in Looprange(1,length(ML))){ GL<- Op(N,ML) Out<- c() for (I in Looprange(1,Nrow(GL))){ if(is.matrix(GL)){ Tmp<- GL[I,] } else{ Tmp<- GL } X1<- Tmp[1] Y1<- Tmp[2] if (X1==Inf){ X2<- X1 Y2<- Y1 } else{ X2<- Cx+(X1-Cx)*cos(Theta)-(Y1-Cy)*sin(Theta) Y2<- Cy+(X1-Cx)*sin(Theta)+(Y1-Cy)*cos(Theta) } Out<- Appendrow(Out,c(X2,Y2)) } if(nrow(Out)==1){ Out<- Out[1,] } OutL<- Mixjoin(OutL,list(Out)) } if (length(OutL)==1){ OutL<- Op(1,OutL) } return(OutL) } ############################################### Scaledata<- function(...) { varargin<- list(...) Nargs<- length(varargin) Eps<- 10^(-8) ML<- varargin[[1]] if (Mixtype(ML)==1){ ML<- list(ML) } A<- varargin[[2]] B<- varargin[[3]] if (Nargs==3){ Pt<- c(0,0) } else{ Pt<- varargin[[4]] } OutL<- list() for (N in Looprange(1,length(ML))){ GL<- Op(N,ML) Out<- c() for (I in Looprange(1,Nrow(GL))){ if(is.matrix(GL)){ # 10.12.07 Tmp<- GL[I,] } else{ Tmp<- GL } X1<- Tmp[1] Y1<- Tmp[2] if (X1==Inf){ X2<- X1 Y2<-Y1 } else{ X2<- Pt[1]+A*(X1-Pt[1]) Y2<- Pt[2]+B*(Y1-Pt[2]) } Out<- Appendrow(Out,c(X2,Y2)) } OutL<- Mixjoin(OutL,list(Out)) } if (length(OutL)==1){ OutL<- Op(1,OutL) } return(OutL) } ################################ Setarrow<- function(...) { varargin<- list(...) Nargs<- length(varargin) if (Nargs==0){ Str<- paste("Size=",YaSize,",","Angle=",YaAngle,",",sep="") Str<- paste(Str,"Position=",YaThick,",","Style=",YaStyle,sep="") return(Str) } Flg<- 0 for (I in 1:Nargs){ Tmp<- varargin[[I]] if (mode(Tmp)=="numeric"){ Flg<- Flg+1 if (Flg==1) YaSize<<-Tmp if (Flg==2){ if (Tmp<5){ YaAngle<<- 18*Tmp } else{ YaAngle<<- Tmp } } if (Flg==3) YaPosition<<- Tmp if (Flg==4) YaThick<<- Tmp } if (mode(Tmp)=="character"){ YaStyle<<- Tmp } } } #################################### Setax<- function(...) { varargin<- list(...) Nargs<- length(varargin) if (Nargs==0){ if (ZIKU=="line"){ Tmp<- "," } else{ Tmp<- paste("(Arrowsize=", as.character(ARROWSIZE),"),",sep="") } Str<- paste(ZIKU,Tmp,XNAME,",",XPOS,",",sep="") Str<- paste(Str,YNAME,",",YPOS,",",ONAME,",",OPOS,sep="") return(Str) } ArgL<- c() Is<- 1 Tmp<- varargin[[1]] if (mode(Tmp)=="numeric" && length(Tmp)==1){ Is<- varargin[[1]] ArgL<- c() for (I in Looprange(1,Is-1)){ ArgL<- c(ArgL,"") } for (I in Looprange(2,Nargs)){ ArgL<- c(ArgL,varargin[[I]]) } } else{ if (Nargs==1){ ArgL<- c(varargin[[1]]) } else{ Tmp<- varargin[[2]] if (mode(Tmp)=="numeric" && length(Tmp)==1){ ARROWSIZE<<-Tmp ArgL<- c(varargin[[1]]) for (I in Looprange(3,Nargs)){ ArgL<- c(ArgL,varargin[[I]]) } } else{ ArgL<- c() for (I in 1:Nargs){ ArgL<- c(ArgL,varargin[[I]]) } } } } for (I in Looprange(length(ArgL)+1,7)){ ArgL<- c(ArgL,"") } Zk<- ArgL[1] if (nchar(Zk)>0){ ZL<-substr(Zk,2,nchar(Zk)) Zk<-substr(Zk,1,1) if (nchar(ZL)>0){ ARROWSIZE<<- as.numeric(ZL) } } Xn<- ArgL[2]; Xp<- ArgL[3] Yn<- ArgL[4]; Yp<- ArgL[5] Genn<- ArgL[6]; Genp<- ArgL[7] if (nchar(Zk)>0){ C<- Zk if (C=="a"){ ZIKU<<- "arrow" } else{ ZIKU<<- "line" } } if (nchar(Xn)>0){ XNAME<<- paste("$",Xn,"$",sep="") } if (nchar(Xp)>0){ XPOS<<- Xp } if (nchar(Yn)>0){ YNAME<<- paste("$",Yn,"$",sep="") } if (nchar(Yp)>0){ YPOS<<-Yp } if (nchar(Genn)>0){ ONAME<<- Genn } if (nchar(Genp)>0){ OPOS<<- Genp } Out<- ""; } ################################# # 11.08.24 Setcolor<- function(...){ varargin<- list(...) Color<- 'black' Kosa<- 1 for(J in Looprange(1,length(varargin))){ Tmp<- varargin[[J]] if(is.character(Tmp)) Color<- Tmp if(is.numeric(Tmp)){ if(length(Tmp)==1){# 11.08.24 Kosa<- Tmp } else{ Color<- Tmp } }# 11.08.24 } Iro<- Ratiocmyk(Color) if(length(Iro)==0) return(c()) Str<- "\\color[cmyk]{" #17.09.22 for(J in 1:4){ Str<- paste(Str,as.character(Kosa*Iro[J]),sep="") if(J<4){ Str<- paste(Str,",",sep="") } } Str<- paste(Str,"}",sep="") Texcom(Str) } ################################## Setmarklen<- function(...) { varargin<- list(...) Nargs<- length(varargin) if (Nargs==0){ Tmp<- MARKLENNow/MARKLENInit Tmp=round(Tmp*100)/100 return(Tmp) } Size<- varargin[[1]] MARKLENNow<<- MARKLENInit*Size MARKLEN<<- MARKLENNow*1000/2.54/MilliIn } ############################### Setorigin<- function(...) { varargin<- list(...) Nargs<- length(varargin) if (Nargs==0){ return(GENTEN) } Pt<- varargin[[1]] GENTEN<<- Pt; } ################################ Setscaling<- function(...) { varargin<- list(...) Nargs<- length(varargin) if (Nargs==0) { return(c(SCALEY,LOGX,LOGY)) } for (I in 1:Nargs) { Tmp<- varargin[[I]] if (mode(Tmp)=="numeric") { SCALEY<<- Tmp } if (mode(Tmp)=="character") { if (Tmp=="l") { LOGX<<- 0 LOGY<<- 1 } else if (Tmp=="ll") { LOGX<<- 1 LOGY<<- 1 } else { LOGX<<- 0 LOGY<<- 0 } } } Tmp<- c(SCALEY,LOGX,LOGY); } ######################################### Setpen<-function(Width) { PenThick<<-round(PenThickInit*Width) Str=paste("\\special{pn ", as.character(PenThick),"}%\n",sep="") cat(Str,file=Wfile,append=TRUE) } ############################################## Setpt<- function(...) { varargin<- list(...) Nargs<- length(varargin) if (Nargs==0) { Tmp<- TenSize/TenSizeInit Tmp<- round(Tmp*100)/100 return(Tmp) } Size<- varargin[[1]] TenSize<<- TenSizeInit*Size; } ############################################## Setunitlen<-function(...) { varargin<-list(...) if (length(varargin)==0){ return(ULEN) } Ul=varargin[[1]] Dx<-XMAX-XMIN Dy<-YMAX-YMIN Sym<-".0123456789 +-*/" SL<-Sym OL<-"+-*/" if (nchar(Ul)>0){ ULEN<<-Ul } Is<-1 VL<-"" Ucode<-ULEN for (I in 1:nchar(Ucode)){ C<-substring(Ucode,I,I) if (length(grep(C,SL))>0){ if (length(grep(C,OL))>0){ Tmp<-substring(Ucode,Is,I-1) Str<-paste(VL,Tmp,C,sep="") VL<-Str Is<-I+1 } } else{ Unit<-substring(Ucode,I,I+1) Str<-substring(Ucode,Is,I-1) VL<-paste(VL,Str,sep="") break; } } Valu<-eval(parse(text=VL)) Str<-as.character(Valu) ULEN<<-paste(Str,Unit,sep=""); if (Unit=="cm") MilliIn<<-1000/2.54*Valu if (Unit=="mm") MilliIn<<-1000/2.54*Valu/10 if (Unit=="in") MilliIn<<-1000*Valu if (Unit=="pt") MilliIn<<-1000/72.27*Valu if (Unit=="pc") MilliIn<<-1000/6.022*Valu if (Unit=="bp") MilliIn<<-1000/72*Valu if (Unit=="dd2") MilliIn<<-1000/1238/1157/72.27*Valu if (Unit=="cc") MilliIn<<-1000/1238/1157/72.27*12*Valu if (Unit=="sp") MilliIn<<-1000/72.27/65536*Valu/10 MARKLEN<<-MARKLENNow*1000/2.54/MilliIn; } ######################################### # 10.11.20 Setwindow<-function(...) { varargin<-list(...) Nargs<-length(varargin) if (Nargs==0){ Out<-c(XMIN,XMAX,YMIN,YMAX) return(Out) } if (Nargs==1){ Dt<- varargin[[1]] if(is.list(Dt) && !is.data.frame(Dt)){ Tmp<- as.data.frame(Dt) Dt<- t(Tmp) } Xm<- min(Dt[,1]) XM<- max(Dt[,1]) Ym<- min(Dt[,2]) YM<- max(Dt[,2]) Str<- "Setwindow(" Str<- paste(Str,"c(",as.character(Xm),",",as.character(XM),"),c(",sep="") Str<- paste(Str,as.character(Ym),",",as.character(YM),")",sep="") Str<- paste(Str,")",sep="") print(Str) } if (Nargs==2){ RgX<-varargin[[1]] RgY<-varargin[[2]] XMIN<<-RgX[1]; XMAX<<-RgX[2] YMIN<<-RgY[1]; YMAX<<-RgY[2] } if (Nargs==4){ XMIN<<-varargin[[1]]; XMAX<<-varargin[[2]] YMIN<<-varargin[[3]]; YMAX<<-varargin[[4]] } Out<- c(XMIN,XMAX,YMIN,YMAX); } ######################################### Shade<- function(...) { ## Scaling is implemented varargin<- list(...) Nargs<- length(varargin) Iroflg=0 Kosa=1 if(Nargs>1){ Iro=varargin[[Nargs]] if(is.character(Iro)){ Iroflg=1 if(length(grep("{",Iro))>0){ Str=paste("{\\color",Iro,sep="") } else{ Str=paste("{\\color{",Iro,"}",sep="") } } else{ if(length(Iro)==1){ Kosa=Iro } else{ Iroflg=1 if(length(Iro)==4){ Str="{\\color[cmyk]{" } else{ if(length(Iro)==3){ Str="{\\color[rgb]{" } } for(J in 1:length(Iro)){ Str=paste(Str,as.character(Iro[J]),sep="") if(J80){ cat("%\n",file=Wfile,append=TRUE) Mojisu<- 0 } } Str1<- paste("\\special{sh ",as.character(Kosa),"}",sep="") Str2<- paste("\\special{ip}%\n",sep="") cat(Str1,file=Wfile,append=TRUE) cat(Str2,file=Wfile,append=TRUE) } if(Iroflg==1){ cat("}%\n",file=Wfile,append=TRUE) } } ####### Shade new 17.09.24############ Shade<- function(...) { ## Scaling is implemented varargin<- list(...) Nargs<- length(varargin) Iroflg<- 0 Kosa<- 1 if (Nargs>1){ Iro<- varargin[[Nargs]] if (mode(Iro)=="character"){ Iroflg<- 1 if (length(grep(Iro,"{"))>0) Str<- paste("{\\color",Iro,sep="") else Str<- paste("{\\color{",Iro,"}",sep="") } else{ if (length(Iro)==1) Kosa<- Iro else{ Iroflg<- 1 if (length(Iro)==4) Str<- paste("{\\color[cmyk]{",sep="") else if (length(Iro)==3) Str<- paste("{\\color[rgb]{",sep="") for (J in Looprange(1,length(Iro))){ Str<- paste(Str,as.character(Iro[J]),sep="") if (J80){ if (Wfile=="default") cat("%\n",file="",append=TRUE,sep="") else cat("%\n",file=Wfile,append=TRUE,sep="") Mojisu<- 0 } } Str1<- paste("\\special{sh ",as.character(Kosa),"}",sep="") Str2<- paste("\\special{ip}%\n",sep="") if (Wfile=="default"){ cat(Str1,file="",append=TRUE,sep="") cat(Str2,file="",append=TRUE,sep="") } else{ cat(Str1,file=Wfile,append=TRUE,sep="") cat(Str2,file=Wfile,append=TRUE,sep="") } } if (Iroflg==1){ if (Wfile=="default") cat("}%\n",file="",append=TRUE,sep="") else cat("}%\n",file=Wfile,append=TRUE,sep="") } } ############################################## # 11.01.07 Splinedata<- function(...) { varargin<- list(...) Nargs<- length(varargin) Eps<- 10^(-3) PL<- varargin[[1]] if (mode(PL)=="character"){ Fname<- PL PL<- Readtextdata(Fname) } else{ PL<- as.matrix(PL) if (Nrow(PL)==1){ PL<- matrix(PL, nrow=length(PL)/2) PL<- t(PL) } } if (ncol(PL)==3){ Flg3<- 1 } else{ Flg3<- 0 } PLL<- Dividegraphics(PL) N<- 50 C<- c() for (I in Looprange(2,Nargs)){ Tmp<- varargin[[I]] if (mode(Tmp)!="character") next if (length(grep("=",Tmp,fixed=TRUE))>0){ eval(parse(text=Tmp)) } else{ Tmp1<- substr(Tmp,1,1) if (toupper(Tmp1)=="C"){ C<- 1:length(PLL) } } } Cflg<- rep(0,length(PLL)) for(J in Looprange(1,length(C))){ K<- C[J] Cflg[K]<- 1 } if (length(N)>1){ Nj<- as.numeric(N) } else{ Tmp<- lapply(PLL,nrow) Tmp1<- as.numeric(Tmp) MxP<- max(Tmp1) Nj<- c() for (J in 1:length(PLL)){ Tmp<- nrow(PLL[[J]]) Tmp1<- round(N/MxP*(Tmp-1)) Nj<- c(Nj,Tmp1) } } OutL<- list() for(J in 1:length(PLL)){ PL<- PLL[[J]] if (Cflg[J]==1){ if (Norm(PL[1,]-PL[Nrow(PL),])>Eps){ PL<-Appendrow(PL,PL[1,]) Nj[J]=round(N/MxP*nrow(PL)) } else{ PL[Nrow(PL),]<- PL[1,] } } Tn<- 1:Nrow(PL) Xn<- PL[,1] Yn<- PL[,2] if (Flg3==1) Zn<- PL[,3] if (Cflg[J]==0){ Dxn<- spline(Tn,Xn,n=Nj[J]) Dyn<- spline(Tn,Yn,n=Nj[J]) if (Flg3==1) Dzn<- spline(Tn,Zn,n=Nj[J]) } else{ Dxn<- spline(Tn,Xn,method="periodic") Dyn<- spline(Tn,Yn,method="periodic") if (Flg3==1) Dzn<- spline(Tn,Zn,method="periodic") } Tmp1<- Dxn$y Tmp2<- Dyn$y Tmp3<-c() if (Flg3==1) Tmp3<- Dzn$y Out<- matrix(c(Tmp1,Tmp2,Tmp3),nrow=length(Tmp1)) OutL<- c(OutL,list(Out)) } return(OutL) } ############################################ # 2013.05.03 Domain is optional Tabledata<- function(...){ varargin<- list(...) Eps<- 0.001 Tmp<- varargin[[1]] # 130503 from if(is.numeric(Tmp)){ Domain<- varargin[[1]] VL<- varargin[[2]] HL<- varargin[[3]] } else{ Domain<- c(-1,-1) VL<- varargin[[1]] HL<- varargin[[2]] } # 130503 upto Hsize<- Domain[1] SvL<- list(0) S<- 0 for (I in Looprange(1,length(VL))){ Tmp<- VL[[I]] S<- S+Tmp[1] Tmp[1]<- S SvL<- c(SvL,list(Tmp)) } if (Hsize>S){ SvL<- c(SvL,list(Hsize)) } Hsize<- Op(1,SvL[[length(SvL)]]) Vsize<- Domain[2] ShL<- list(0) S<- 0 for (I in Looprange(1,length(HL))){ Tmp<- HL[[I]] S<- S+Tmp[1] Tmp[1]<- S ShL<- c(ShL,list(Tmp)) } if (Vsize>S){ ShL<- c(ShL,list(Vsize)) } Vsize<- Op(1,ShL[[length(ShL)]]) Marw<- 0; Mare<- 0; Mars<- 0; Marn<- 0 if (length(Domain)>2){ Marw<- Domain[3] Mare<- Domain[4] } if (length(Domain)>4){ Marn<- Domain[5] Mars<- Domain[6] } Setwindow(c(-Marw,Hsize+Mare),c(-Mars,Vsize+Marn)) Tmp<- Framedata(c(Eps,Hsize-Eps),c(Eps,Vsize-Eps)) Gdata<- list(Tmp) Tmp<- -Marw Hdata<- list(Listplot(c(c(Tmp,-Mars),c(Tmp,Vsize+Marn)))) for (I in Looprange(1,length(SvL))){ Data<- SvL[[I]] X<- Data[1] if (length(Data)==1){ Y1<- 0 Y2<- Vsize G<- Listplot(c(X,Y1),c(X,Y2)) } else{ G<- c() for (J in seq(2,length(Data),by=2)){ Y1<- Vsize-Op(1,ShL[[Data[J]]]) Y2<- Vsize-Op(1,ShL[[Data[J+1]]]) Tmp<- Listplot(c(c(X,Y1),c(X,Y2))) Tmp1<- Appendrow(G,c(Inf,Inf)) G<- Appendrow(Tmp1,Tmp) } G<- G[2:nrow(G),] } Hdata<- c(Hdata,list(G)) } Tmp<- Hsize+Mare Tmp1<- Listplot(c(c(Tmp,-Mars),c(Tmp,Vsize+Marn))) Hdata<- c(Hdata,list(Tmp1)) Tmp<- Vsize+Marn Vdata<- list(Listplot(c(c(-Marw,Tmp),c(Hsize+Mare,Tmp)))) for (I in Looprange(1,length(ShL))){ Data<- ShL[[I]] Y<- Vsize-Data[1] if (length(Data)==1){ X1<- 0 X2<- Hsize G<- Listplot(c(X1,Y),c(X2,Y)) } else{ G<- c() for (J in seq(2,length(Data),by=2)){ X1<- Op(1,SvL[[Data[J]]]) X2<- Op(1,SvL[[Data[J+1]]]) Tmp<- Listplot(c(X1,Y),c(X2,Y)) G<- Appendrow(G,c(Inf,Inf)) G<- Appendrow(G,Tmp) } G<-G[2:nrow(G),] } Vdata<- c(Vdata,list(G)) } # Tmp<- Listplot(c(c(0,0),c(Hsize,0))) # 2011.03.02 # Vdata<- Mixjoin(Vdata,list(Tmp)) Tmp<- Listplot(c(c(-Marw,-Mars),c(Hsize+Mare,-Mars))) Vdata<- Mixjoin(Vdata,list(Tmp)) Tmp1<- Hdata[Looprange(3,length(Hdata)-2)] Tmp2<- Vdata[Looprange(3,length(Vdata)-2)] Gdata<- Mixjoin(Gdata,Tmp1,Tmp2) Hind<- Looprange(2,1+length(Tmp1)) Vind<- Looprange(2+length(Tmp1),1+length(Tmp1)+length(Tmp2)) G=Gdata[[1]] P1<- Ptsw(G); P2<- Ptnw(G) Q1<- Ptse(G); Q2<- Ptne(G) Tmp1<- list(Listplot(c(P1,P2)),Listplot(c(Q1,Q2))) P1<- Ptnw(G); P2<- Ptne(G) Q1<- Ptsw(G); Q2<- Ptse(G) Tmp2<- list(Listplot(c(P1,P2)),Listplot(c(Q1,Q2))) Tmp3<- Framedata() Out<- list(Gdata,Hind,Vind,Tmp1,Tmp2,Tmp3) return(Out) } ################################ Texcom<- function(Meirei) { if (Meirei=="\\thinlines"){ Setpen(1); return(); } if (Meirei=="\\thicklines"){ Setpen(2); return() } if (Meirei=="\\Thicklines"){ Setpen(3); return() } if (length(Meirei)==0){ # 09.12.07 Tmp<- c() } else{ Tmp<- grep("newline",Meirei) } if (length(Tmp)>0){ cat("\n",file=Wfile,append=TRUE); } else{ Tmp<- paste(Meirei,"%\n",sep="") Tmp<- gsub("//","\\",Tmp,fixed=TRUE) # 11.03.02 cat(Tmp,file=Wfile,append=TRUE); } } ############################################### Texctr<- function(N){ if (is.numeric(N)){ Alpha<- "abcdefghijklmnopqrstuvwxyz" Out<- paste("ketpicctr",substr(Alpha,N,N),sep="") } else{ if(grep("\\",N,fixed=TRUE)>0){ Out<- substr(N,2,nchar(N)) } else{ Out<- N } } return(Out) } ############################################### Texelse<- function (){ Texcom(""); Texcom("\\else") } ############################################### Texend<- function() { Texcom("%\n}") } ############################################### Texendfor<- function(I){ Last<- TEXFORLAST[[TEXFORLEVEL]] Texcom("") Tmp<- paste("\\ifnum",Texthectr(I),"<",Last,sep="") Texcom(Tmp) Texcom("\\repeat") Texcom("}") TEXFORLEVEL<<- TEXFORLEVEL-1 TEXFORLAST<<- TEXFORLAST[1:(length(TEXFORLAST)-1)] } ############################################### Texendif<- function(){ Texcom("") Texcom("\\fi") Texcom("}") } ############################################### Texfor<- function(I,First,Last){ TEXFORLEVEL<<- TEXFORLEVEL+1; Texsetctr(I,"0") Texsetctr(I,paste(as.character(First),"-1",sep="")) Texcom("") Texcom("{") Texcom("\\loop") Texsetctr(I,"+1") TEXFORLAST<<- c(TEXFORLAST,as.character(Last)) } ############################################### Texforinit<- function(){ TEXFORLEVEL<<- 0 TEXFORLAST<<- list() } ############################################### Texif<- function(...){ varargin<- list(...) Condstr<- varargin[[1]] Tp<- 0 if(length(varargin)>1){ Tp<- varargin[[2]] } Texcom("") Texcom("{") if(Tp==0){ Texcom("\\ifnum") } else{ Texcom("\\ifdim ") } Texcom(paste(Condstr," ",sep="")) } ###################################### Texletter<- function(...) { varargin<- list(...) Nargs<- length(varargin) for (I in seq(1,Nargs,by=3)){ P<- varargin[[I]] X<- P[1] if (mode(X)=="numeric"){ X<- as.character(X) } Y<- P[2] if (mode(Y)=="numeric"){ Y<- as.character(Y) } Houkou<- varargin[[I+1]] Mojiretu<- varargin[[I+2]] Hset<- Houkou Vhoko<- "c" if (length(grep("n",Hset))>0){ Vhoko<- "n" } if (length(grep("s",Hset))>0){ Vhoko<- "s" } Hhoko<- "c"; if (length(grep("e",Hset))>0){ Hhoko<- "e" } if (length(grep("w",Hset))>0){ Hhoko<- "w" } Hoko<- paste(Vhoko,Hhoko,sep="") CalcWidth(Hoko,Mojiretu) CalcHeight(Hoko,Mojiretu) Tmp<- paste("\\put(",X,",",Y,"){\\hspace*{\\Width}",sep="") Str<- paste(Tmp,"\\raisebox{\\Height}{",Mojiretu,"}}%\n",sep="") cat(Str,file=Wfile,append=TRUE) } } ################################################## Texnewcmd<- function(...) { varargin<- list(...) Nargs<- length(varargin) Str<- varargin[[1]] S<- paste("\\newcommand{",Str,"}",sep="") if (Nargs>1){ Tmp<- as.character(varargin[[2]]) S<- paste(S,"[",Tmp,"]",sep="") } if (Nargs>2){ Tmp<- varargin[[3]] if (mode(Tmp)=="numeric"){ Tmp<- as.character(Tmp) } S<- paste(S,"[",Tmp,"]",sep="") } S<- paste(S,"{",sep="") Texcom(S) } ############################################### Texnewctr<- function(N) { if (mode(N)=="character"){ Str<- paste("\\newcounter{",N,"}",sep="") Texcom(Str) } else{ for (I in N){ Str<- paste("\\newcounter{",Texctr(I),"}",sep="") Texcom(Str) } } } ############################################### Texrenewcmd<- function(...) { varargin<- list(...) Nargs<- length(varargin) Str<- varargin[[1]] S<- paste("\\renewcommand{",Str,"}",sep="") if (Nargs>1){ Tmp<- as.character(varargin[[2]]) S<- paste(S,"[",Tmp,"]",sep="") } if (Nargs>2){ Tmp<- varargin[[3]] if (mode(Tmp)=="numeric"){ Tmp<- as.character(Tmp) } S<- paste(S,"[",Tmp,"]",sep="") } S<- paste(S,"{",sep="") Texcom(S) } ############################################### Texsetctr<- function(Nctr,Opstr) { Ctr<- Texctr(Nctr) Opstr<- paste(Opstr,"%",sep="") OperL<- "+-*/%" Oper<- "" Va<- "" Evflg<- 0 Paflg<- 0 for (I in Looprange(1,nchar(Opstr))){ Tmp<- substring(Opstr,I,I) if (Tmp=="("){ Paflg<- 1 if (nchar(Va)>0){ Evflg<- 1 Va<- paste(Va,Tmp,sep="") } next } if (Tmp==")"){ Paflg<- 0 if (Evflg>0){ Va<- paste(Va,Tmp,sep="") } next } if (Paflg>0){ Va<- paste(Va,Tmp,sep="") next } if (length(grep(Tmp,OperL))==0){ Va<- paste(Va,Tmp,sep="") } else{ if (Evflg>0){ Tmp1<- eval(parse(text=Va)) Va<- paste("\\value{",Tmp1,"}",sep="") Evflg<- 0 } if (Oper==""){ if(nchar(Va)>0){ Str<- paste("\\setcounter{",Ctr,"}{",Va,"}",sep="") Texcom(Str) } Oper<- Tmp Va<-"" } else if(Oper=="+"){ Str<- paste("\\addtocounter{",Ctr,"}{",Va,"}",sep="") Texcom(Str) Oper<- Tmp Va<-"" } else if(Oper=="-"){ Str<- paste("\\addtocounter{",Ctr,"}{-",Va,"}",sep="") Texcom(Str) Oper<- Tmp Va<-"" } else if(Oper=="*"){ Str<- paste("\\multiply\\value{",Ctr,"} by ",Va,sep="") Texcom(Str) Oper<- Tmp Va<-"" } else if(Oper=="/"){ Str<- paste("\\divide\\value{",Ctr,"} by ",Va,sep="") Texcom(Str) Oper<- Tmp Va<-"" } } } } ############################################### Texthectr<- function(N) { Out<- paste("\\the",Texctr(N),sep="") return(Out) } ############################################### Texvalctr<- function(N){ Out<- paste("\\value{",Texctr(N),"}",sep="") return(Out) } ############################################### Texvctr<- function(N) { Out<- paste("\\value{",Texctr(N),"}",sep="") return(Out) } ############################################### Tonumeric <- function(...) { varargin<- list(...) Nargs<- length(varargin) Data<- varargin[[1]] Sp<- c(1,1) Ep<- c(Inf,Inf) if (Nargs>1){ Sp<- varargin[[2]] } if (Nargs>2){ Ep<- varargin[[3]] } Nrs<- Sp[1] Nre<- min(nrow(Data),Ep[1]) Ncs<- Sp[2] Nce<- min(ncol(Data),Ep[2]) Tmp1<- Data[Nrs:Nre, Ncs:Nce] Tmp2 <- as.numeric(Tmp1) Out <- matrix(Tmp2,nrow=nrow(Tmp1)) Sp<- c() for (I in 1:nrow(Out)){ for (J in 1:ncol(Out)){ Tmp<- Out[I,J] if (!is.na(Tmp)){ Sp<- c(I,J) break; } } if (length(Sp)>0) break } if (length(Sp)==0){ return("Numeric data not found") } Ep<- c(nrow(Out),ncol(Out)) for (I in Sp[1]:nrow(Out)){ Tmp<- Out[I,Sp[2]] if (is.na(Tmp)){ Ep[1]<- I-1 break } } for (J in Sp[2]:ncol(Out)){ Tmp<- Out[Sp[1],J] if (is.na(Tmp)){ Ep[2]<- J-1 break } } Out<- Out[Sp[1]:Ep[1], Sp[2]:Ep[2]] return(Out) } ################################################## Translatedata<- function(...) { varargin<- list(...) Nargs<- length(varargin) Eps<- 10^(-8) ML<- varargin[[1]] if (Mixtype(ML)==1){ ML<- list(ML) } Tmp=varargin[[2]] if (mode(Tmp)=="numeric" && length(Tmp)>1){ A<- Tmp[1]; B<- Tmp[2] } else{ A<- Tmp if (Nargs>=3){ B<- varargin[[3]] } else{ B<- 0 } } OutL<- list() for (N in Looprange(1,length(ML))){ GL<- Op(N,ML) Out<- c() for (I in Looprange(1,Nrow(GL))){ if(is.matrix(GL)){ # 10.12.07 Tmp<- GL[I,] } else{ Tmp<- GL } X1<- Tmp[1] Y1<- Tmp[2] if (X1==Inf){ X2<- X1 Y2<-Y1 } else{ X2<- X1+A Y2<- Y1+B } Out<- Appendrow(Out,c(X2,Y2)) } OutL<- Mixjoin(OutL,list(Out)) } if (length(OutL)==1){ OutL<- Op(1,OutL) } return(OutL) } ####################################### Unscaling<- function(G) { GLg<- G if (class(GLg)=="numeric"){ GLg<-c(G[1]/SCALEX, G[2]/SCALEY) Tmp<-GLg if (LOGX==1) Tmp[1]<- 10^(GLg[1]) if (LOGY==1) Tmp[2]<- 10^(GLg[2]) return(Tmp) } else{ Tmp1<-matrix(c(1/SCALEX,0,0,1/SCALEY),nrow=2) GLg<-G %*% Tmp1 Tmp<-GLg if (LOGX==1) Tmp[,1]<- 10^(G[,1]) if (LOGY==1) Tmp[,2]<- 10^(G[,2]) return(Tmp) } } ############################################# Vtickmark<- function(...) { ## Scaling is implemented varargin<- list(...) Nargs<- length(varargin) ArgsL<- varargin if (mode(ArgsL[[1]])=="character"){ Str<- ArgsL[[1]] Tmp<- strsplit(Str,"m") Tmp<- Tmp[[1]] if (length(Tmp)>1){ I<- nchar(Tmp[1])+1 } else{ I<- 0 } Tmp<- strsplit(Str,"n") Tmp<- Tmp[[1]] if (length(Tmp)>1){ J<- nchar(Tmp[1])+1 } else{ J<- 0 } Tmp<- strsplit(Str,"r") Tmp<- Tmp[[1]] if (length(Tmp)>1){ K=nchar(Tmp[1])+1 } else{ K<- 0 } if (K>0){ S<- substr(Str,K+1,nchar(Str)) R<- as.numeric(S) if (is.na(R)){ R<- 1 } } else{ R<- 1 K<- nchar(Str)+1 } if (J>0){ S<- substr(Str,J+1,K-1) Dn<- as.numeric(S) if (is.na(Dn)){ Dn<- 1 } } else{ Dn<- 1000 J<- nchar(Str)+1 } S<- substr(Str,I+1,J-1) Dm<- as.numeric(S) if (is.na(Dm)){ Dm<- 1 } ArgsL<- list() for (I in 1:floor((YMAX-GENTEN[2])/Dm)){ ArgsL<- Mixjoin(ArgsL,I*Dm) if (I-floor(I/Dn)*Dn==0){ Str<- as.character(I*Dm*R) ArgsL<- Mixjoin(ArgsL,Str) } } for (I in seq(-1,ceiling((YMIN-GENTEN[2])/Dm))){ ArgsL<- Mixjoin(ArgsL,I*Dm) if (I-floor(I/Dn)*Dn==0){ Str<- as.character(I*Dm*R) ArgsL<- Mixjoin(ArgsL,Str) } } } MemoriList<- list() Memori<- list() for (N in 1:length(ArgsL)){ Dt<- ArgsL[[N]] if (mode(Dt)=="numeric" && length(Dt)>1){ if (length(Memori)>0){ MemoriList<- Mixjoin(MemoriList,list(Memori)) } Memori<- list(Dt[1],Dt[2]) next } if (mode(Dt)=="character"){ Memori<- Mixjoin(Memori,Dt) } else{ if (length(Memori)>0){ MemoriList<- Mixjoin(MemoriList,list(Memori)) } Memori<- list(GENTEN[1],Dt) } } MemoriList<- Mixjoin(MemoriList,list(Memori)) for (N in 1:length(MemoriList)){ Dt<- MemoriList[[N]] Ndt<- length(Dt) X=Op(1,Dt) Y=Op(2,Dt) Tmp<-Doscaling(c(X,Y)) X<- Tmp[1] Y<- Tmp[2] Moji<- Op(Ndt,Dt) Tmp1<- Unscaling(c(X+MARKLEN,Y)) Tmp2<- Unscaling(c(X-MARKLEN,Y)) Fd<- Listplot(c(Tmp1,Tmp2)) Drwline(Fd) if (Ndt==3){ Tmp<-Unscaling(c(X-MARKLEN,Y)) Expr(Tmp,"w",Moji) } if (Ndt==4){ Houkou<- Op(3,Dt) Tmp<-grep("w",Houkou) if (length(Tmp)>0){ Tmp<-Unscaling(c(X-MARKLEN,Y)) Expr(Tmp,Houkou,Moji) } else{ Tmp<- Unscaling(c(X+MARKLEN,Y)) Expr(Tmp,Houkou,Moji) } } cat("%\n",file=Wfile,append=TRUE) } } ############################################ Windisp<-function(...){ varargin<-list(...) Nargs<-length(varargin) Tmp<- Doscaling(c(XMIN,YMIN)) Xmn<- Tmp[1]; Ymn<- Tmp[2] Tmp<- Doscaling(c(XMAX,YMAX)) Xmx<- Tmp[1]; Ymx<- Tmp[2] plot(c(Xmn,Xmx),c(Ymn,Ymx),type="n",asp=1,axes=FALSE,xlab="",ylab="") Tmp<- Doscaling(Listplot(c(0,YMIN),c(0,YMAX))) axis(2,at=as.numeric(Tmp[,2]), labels=round(c(YMIN,YMAX),2)) Tmp<- Doscaling(Listplot(c(XMIN,0),c(XMAX,0))) axis(1,at=as.numeric(Tmp[,1]), labels=round(c(XMIN,XMAX),2)) Tmp1<- c(XMIN,GENTEN[2]) Tmp2<- c(XMAX,GENTEN[2]) Tmp3<- Listplot(Tmp1,Tmp2) Tmp<- MakeCurves(Tmp3,0) if (Datalength(Tmp)>0){ lines(Tmp[,1],Tmp[,2],col="green") } Tmp1<- c(GENTEN[1],YMAX) Tmp2<- c(GENTEN[1],YMIN) Tmp3<- Listplot(Tmp1,Tmp2) Tmp<- MakeCurves(Tmp3,0) if (Datalength(Tmp)>0){ lines(Tmp[,1],Tmp[,2],col="green") } Tmp<-Doscaling(Framedata()) lines(Tmp[,1],Tmp[,2]) for (I in Looprange(1,Nargs)){ Pdata<-varargin[[I]] if (mode(Pdata)=="numeric"){ Pdata<-list(Pdata) } while(Mixtype(Pdata)==3){ # 10.02.23 Tmp1<- list() for(II in Looprange(1,length(Pdata))){ Tmp1<- Mixjoin(Tmp1,Pdata[[II]]) } Pdata<- Tmp1 } # 10.02.23 for (II in Looprange(1,length(Pdata))){ Tmp<-Pdata[[II]] P<-MakeCurves(Tmp,0) Ndm<-Dataindex(P) for (J in Looprange(1,Nrow(Ndm))){ Q<-P[Ndm[J,1]:Ndm[J,2],] if (Nrow(Q)==1){ Tmp<-seq(1,Ncol(Q),by=2) for (K in Tmp){ Pt<-Q[K:(K+1)] points(Pt[1],Pt[2]) } } else{ lines(Q[,1],Q[,2]) } } } } } ############################################ WindispT<-function(..., color="black",width=1,new=FALSE,htick=c(),vtick=c()){ # 10.12.04 par(new=new) varargin<-list(...) Nargs<-length(varargin) if(!new) # 10.12.04 { Tmp<- Doscaling(c(XMIN,YMIN)) Xmn<- Tmp[1]; Ymn<- Tmp[2] Tmp<- Doscaling(c(XMAX,YMAX)) Xmx<- Tmp[1]; Ymx<- Tmp[2] plot(c(Xmn,Xmx),c(Ymn,Ymx),type="n",asp=1,axes=FALSE,xlab="",ylab="") Tick<- sort(c(YMIN,YMAX,vtick)) #### 10.12.04 from here Tmp1<- matrix(c(rep(0,length(Tick)),Tick),ncol=2) Tmp<- Doscaling(Tmp1) axis(2,at=as.numeric(Tmp[,2]), labels=round(Tick,2)) Tick<- sort(c(XMIN,XMAX,htick)) Tmp1<- matrix(c(Tick,rep(0,length(Tick))),ncol=2) Tmp<- Doscaling(Tmp1) axis(1,at=as.numeric(Tmp[,1]), labels=round(Tick,2)) #### 10.12.04 to here Tmp1<- c(XMIN,GENTEN[2]) Tmp2<- c(XMAX,GENTEN[2]) Tmp3<- Listplot(Tmp1,Tmp2) Tmp<- MakeCurves(Tmp3,0) if (Datalength(Tmp)>0){ lines(Tmp[,1],Tmp[,2],col="green") } Tmp1<- c(GENTEN[1],YMAX) Tmp2<- c(GENTEN[1],YMIN) Tmp3<- Listplot(Tmp1,Tmp2) Tmp<- MakeCurves(Tmp3,0) if (Datalength(Tmp)>0){ lines(Tmp[,1],Tmp[,2],col="green") } Tmp<-Doscaling(Framedata()) lines(Tmp[,1],Tmp[,2]) } for (I in Looprange(1,Nargs)){ Pdata<-Flattenlist(varargin[[I]]) # 101129 from here Cmd<- list() for (II in Looprange(1,length(Pdata))){ Tmp<-Pdata[[II]] if(length(Tmp)==1){ Cmd<- c(Cmd,list(Tmp)) next } P<-MakeCurves(Tmp,0) if(length(Cmd)>0){ if(length(Cmd)>=3){ polygon(P,col=Cmd[[1]],border=Cmd[[2]],density=Cmd[[3]]) } else{ polygon(P,col=Cmd[[1]],border=Cmd[[2]]) } next } # 101129 to here Ndm<-Dataindex(P) for (J in Looprange(1,Nrow(Ndm))){ Q<-P[Ndm[J,1]:Ndm[J,2],] if (Nrow(Q)==1){ Tmp<-seq(1,Ncol(Q),by=2) for (K in Tmp){ Pt<-Q[K:(K+1)] points(Pt[1],Pt[2],col=color)#taka101111 } } else{ lines(Q[,1],Q[,2],col=color,lwd=width)#taka101111 } } } } par(new=FALSE) } ###################################### # 3D ################################# # 10.08.16 CameracoordCurve<- function(Curve){ Out<- c() for(J in Looprange(1,Nrow(Curve))){ P<- Ptcrv(J,Curve) #P=Curve(J,:); Tmp<- P-FocusPoint X1<- Tmp[1]; Y1<- Tmp[2]; Z1<- Tmp[3] Tmp<- EyePoint-FocusPoint E1<- Tmp[1]; F1<- Tmp[2]; G1<- Tmp[3] Ca<- E1/sqrt(E1^2+F1^2) Sa<- F1/sqrt(E1^2+F1^2) X2<- X1*Ca+Y1*Sa; Y2<- -X1*Sa+Y1*Ca; Z2<- Z1 E2<- E1*Ca+F1*Sa; F2<- -E1*Sa+F1*Ca; G2<- G1 Cb<- E2/sqrt(E2^2+G2^2) Sb<- G2/sqrt(E2^2+G2^2) X3<- X2*Cb+Z2*Sb; Y3<- Y2; Z3<- -X2*Sb+Z2*Cb E3<- E2*Cb+G2*Sb; F3<- F2; G3<- -E2*Sb+G2*Cb Xz<- X3 Yz<- E3/(E3-X3)*Y3 Zz<- E3/(E3-X3)*Z3 Out<- rbind(Out,c(Yz,Zz,Xz)) } rownames(Out)<- 1:Nrow(Out) return(Out) } ######################################### #100815 CameraCurve<- function(Curve){ Eps<- 10^(-6) for (I in Looprange(1,Nrow(Curve))){ P<- Curve[I,] x<- P[1]; y<- P[2]; z<- P[3] if (x!=Inf){ Tmp<- Perspt(P) if (I==1){ AnsL<- rbind(c(),Tmp) }else{ Tmp1<- AnsL[Nrow(AnsL),] if (Tmp1[1]==Inf || Norm(Tmp-Tmp1)>Eps){ AnsL<- rbind(AnsL,Tmp) } } }else{ AnsL<- rbind(AnsL,c(Inf,Inf)) } } rownames(AnsL)<- 1:Nrow(AnsL) return(AnsL) } ###################################### Cancoordpara<- function(P){ # 13.10.06 Xz<- P[1] Yz<- P[2] Zz<- P[3] X<- Xz*sin(PHI)-Yz*cos(PHI)*cos(THETA)+Zz*cos(PHI)*sin(THETA) Y<- Xz*cos(PHI)-Yz*sin(PHI)*cos(THETA)+Zz*sin(PHI)*sin(THETA) Z<- Yz*sin(THETA)+Zz*cos(THETA) Out<- c(X,Y,Z) return(Out) } ###################################### Cancoordpers<- function(P){ Tmp<- EyePoint-FocusPoint E1<- Tmp[1]; F1<- Tmp[2]; G1<- Tmp[3] Ca<- E1/sqrt(E1^2+F1^2) Sa<- F1/sqrt(E1^2+F1^2) E2<- E1*Ca+F1*Sa; F2<- -E1*Sa+F1*Ca; G2<- G1 Cb<- E2/sqrt(E2^2+G2^2) Sb<- G2/sqrt(E2^2+G2^2) E3<- E2*Cb+G2*Sb; F3<- F2; G3<- -E2*Sb+G2*Cb Xz<- P[3]; Yz<- P[1]; Zz<- P[2] X3<- Xz; Y3<- Yz*(E3-Xz)/E3; Z3<- Zz*(E3-Xz)/E3 X2<- X3*Cb-Sb*Z3; Y2<- Y3; Z2<- Cb*Z3+Sb*X3 X1<- X2*Ca-Sa*Y2; Y1<- Ca*Y2+Sa*X2; Z1<- Z2 X<- X1+FocusPoint[1] Y<- Y1+FocusPoint[2] Z<- Z1+FocusPoint[3] Out<- c(X,Y,Z) return(Out) } ####################################### Embed <- function(...){ varargin<- list(...) Nargs<- length(varargin) Pd3<- varargin[[1]] if(Mixtype(Pd3)==1){ Pd3<- list(Pd3) } else if(Mixtype(Pd3)==3){ Tmp<- list(); for(I in Looprange(1,length(Pd3))){ Tmp<- c(Tmp,Pd3[[I]]) } Pd3<- Tmp } Tmpf=varargin[[2]] if(mode(Tmpf)=="character"){ Tmp<- varargin[[3]] Tmp1<- gsub("c(","(",Tmp,fixed=TRUE) Vstr<- gsub(")",")",Tmp1,fixed=TRUE) Str<- paste("Tmpfn<- function",Vstr,"{",Tmpf,"}",sep="") eval(parse(text=Str)) } else{ Tmpfn<- Tmpf } Out<- list() for(I in Looprange(1,length(Pd3))){ PD<- Pd3[[I]] Ans<- c() for(J in Looprange(1,Nrow(PD))){ P<- PD[J,] Tmp<- Tmpfn(P[1],P[2]) Ans<- rbind(Ans,Tmp) } Out<- c(Out, list(Ans)) } if(length(Out)==1){ Out<- Out[[1]] } return(Out) } ####################### # 10.08.17 # 14.03.30 Facesdata<- function(...){ varargin<-list(...) Nargs<- length(varargin) FL<- varargin[[1]] PT<- varargin[[length(varargin)]] Tmp<-grep("para",PT,fixed=TRUE) if (length(Tmp)>0){ Ptype<- 1 }else{ Ptype<- -1 } if (Nargs==2){ CLadd<- list() }else{ CLadd<- varargin[[2]] } NohiddenL<- list() HiddenL<- list() Eps<- 10^(-4) if (length(CLadd)>0){ if (mode(CLadd)=="numeric"){ C<- list() if (Nrow(CLadd)>1){ for (I in Looprange(1,Nrow(CLadd))){ C<- c(C,list(CLadd[I,])) } }else{ I<- 1 while (I<=Ncol(CLadd)){ C<- c(C,list(CLadd[1,I:(I+2)])) I<- I+3 } } CrvL<- list(C) }else if (mode(CLadd[[1]])=="numeric"){ CrvL<- list() for (J in Looprange(1,length(CL))){ Ctmp<- CLadd[[J]] C<- list() if (Nrow(Ctmp)>1){ for (I in Looprange(1,Nrow(Ctmp))){ C<- c(C,list(Ctmp[I,])) } }else{ I<- 1 while(I<=Ncol(Ctmp)){ C<- c(C,list(Ctmp[1,I:(I+2)])) I<- I+3 } } CrvL<- c(CrvL,list(C)) } }else{ CrvL<- CLadd } }else{ CrvL<- list() } Out<- MakeveLfaceL(FL) VELNO<<- Out[[1]] VELHI<<- list() for (I in Looprange(1,length(CrvL))){ Tmp<- CrvL[[I]] for (J in Looprange(1,length(Tmp)-1)){ Edge<- list(Tmp[J],Tmp[J+1]) Ntmp<- length(VELNO) VELNO(Ntmp+1)<<- list(Edge,0,Ntmp+1) } } FaceL<- Out[[2]] Tmp<- grep("raw",PT,fixed=TRUE) if (length(Tmp)==0){ for (Nf in Looprange(1,length(FaceL))){ Face<- FaceL[[Nf]] Menkakusi2(Face,Nf,Ptype) } } for (I in Looprange(1,length(VELNO))){ Edge<- Op(1,VELNO[[I]]) if (Norm(Edge[[1]]-Edge[[2]])>Eps){ NohiddenL<- c(NohiddenL,list(Spaceline(Edge))) } } EdgeL<- list() # from 13.03.30 for(K in Looprange(1,length(VELHI))){ Edge<- Op(1,VELHI[[K]]) P<- Edge[[1]]; Q<- Edge[[2]] if(Norm(P-Q)>Eps){ EdgeL<- c(EdgeL,list(Edge)) } } for(K in Looprange(1,length(EdgeL))){ Edge<- EdgeL[[K]] P<- Edge[[1]]; Q<- Edge[[2]] Cflg<- 0 for(J in Looprange(K+1,length(EdgeL))){ Ej<- EdgeL[[J]] Pj<- Ej[[1]]; Qj<- Ej[[2]] if(Norm(Crossprod(Q-P,Qj-Pj))>Eps){ next } if(Norm(Q-Pj)0){ break } } Urg<- Stripblanks(Op(Jrg,FdL)) StrV<- strsplit(Urg,"=",fixed=TRUE)[[1]] Uname<-StrV[1] Vrg<- Stripblanks(Op(Jrg+1,FdL)) StrV<- strsplit(Vrg,"=",fixed=TRUE)[[1]] Vname<- StrV[1] if (Jrg==2){ Tmp<- Stripblanks(Op(1,FdL)) StrV<- strsplit(Tmp,"=",fixed=TRUE)[[1]] Zf<- StrV[2] Tmp<- list(Uname,Vname,Zf,Urg,Vrg) Out<- c(Out,Tmp) }else if (Jrg==4){ Tmp<- Stripblanks(Op(1,FdL)) StrV<- strsplit(Tmp,"=",fixed=TRUE)[[1]] Zf<- StrV[2] Tmp<- Stripblanks(Op(2,FdL)) StrV<- strsplit(Tmp,"=",fixed=TRUE)[[1]] Xname<- StrV[1] Xf<- StrV[2] Tmp<- Stripblanks(Op(3,FdL)) StrV<- strsplit(Tmp,"=",fixed=TRUE)[[1]] Yname<- StrV[1] Yf<- StrV[2] Tmp<- gsub(Xname,paste("(",Xf,")",sep=""),Zf,fixed=TRUE) Zf<- gsub(Yname,paste("(",Yf,")",sep=""),Tmp,fixed=TRUE) Tmp<- list(Xf,Yf,Zf,Urg,Vrg) Out<- c(Out,Tmp) }else{ Tmp<- Stripblanks(Op(2,FdL)) StrV<- strsplit(Tmp,"=",fixed=TRUE)[[1]] Xf<- StrV[2] Tmp<- Stripblanks(Op(3,FdL)) StrV<- strsplit(Tmp,"=",fixed=TRUE)[[1]] Yf<- StrV[2] Tmp<- Stripblanks(Op(4,FdL)) StrV<- strsplit(Tmp,"=",fixed=TRUE)[[1]] Zf<- StrV[2] Tmp<- list(Xf,Yf,Zf,Urg,Vrg) Out<- c(Out,Tmp) } DrwS<- "enws" BdyL<- c() for (I in Looprange(Jrg+2,Mixlength(FdL))){ Tmp<- Op(I,FdL) if (mode(Tmp)=="character"){ if (length(Tmp)==0){ Tmp<- " " } DrwS<- Tmp } if (mode(Tmp)=="numeric" && Ncol(Tmp)>1){ BdyL<- Tmp } } Tmp<- list(DrwS,BdyL) Out<- c(Out,Tmp) return(Out) } #################################### Initangle<- function (){ PHI<<- 30*pi/180 THETA<<- 60*pi/180 } ########################## Invparapt<- function(...){ varargin<- list(...) Eps<- 10^(-4) Fk<- varargin[[length(varargin)]] NFk<- Numptcrv(Fk) Tmp<- varargin[[1]] if (mode(Tmp)=="numeric" && length(Tmp)==1){ # debug Ph<- Tmp Fh<- varargin[[2]] }else{ Fh<- Projpara(Fk) if (NFk>2){ Tmp1<- Nearestpt(Tmp,Fh) Ph<- Tmp1[[2]] }else{ Ah<- Ptcrv(1,Fh); Bh=Ptcrv(2,Fh) V1<- Tmp-Ah; V2<- Bh-Ah Tmp1<- Crossprod(V1,V2) if (abs(Tmp1)>Eps){ print("Not on the line") return(c()) }else{ Ph<- Dotprod(V1,V2)/Norm(V2)^2+1 } } } if (NFk>2){ N<- trunc(Ph) S0<- Ph-N if (Ph>Numptcrv(Fh)-Eps){ Out<- list(Ptend(Fk),Numptcrv(Fh)) return(Out) } }else{ N<- 1 S0<- Ph-1 } Ak<- Ptcrv(N,Fk); Bk=Ptcrv(N+1,Fk) Ah<- Ptcrv(N,Fh); Bh=Ptcrv(N+1,Fh) Ph<- (1-S0)*Ah+S0*Bh T2<- S0 Pk<- (1-T2)*Ak+T2*Bk Out<- list(Pk,N+T2) return(Out) } ################################# #100815 Invperspt<- function(...){ varargin<-list(...) Eps<- 10^(-4) Fk<- varargin[[length(varargin)]] NFk<- Numptcrv(Fk) Tmp<- varargin[[1]] if (mode(Tmp)=="numeric" && length(Tmp)==1){ Ph<- varargin[[1]] Fh<- varargin[[2]] }else{ Fh<- Projpers(Fk) if (NFk>2){ Tmp1<- Nearestpt(Tmp,Fh) Ph<- Tmp1[[2]] }else{ Ah<- Ptcrv(1,Fh); Bh<- Ptcrv(2,Fh) V1<- Tmp-Ah; V2<- Bh-Ah Tmp1<- Crossprod(V1,V2) if (abs(Tmp1)>Eps){ print("Not on the line") Out<- c() return(Out) }else{ Ph<- Dotprod(V1,V2)/Norm(V2)^2+1# 09.11.12 } } } if (NFk>2){ N<- trunc(Ph) S0<- Ph-N if (Ph>Numptcrv(Fh)-Eps){ Out<- list(Ptend(Fk),Numptcrv(Fh)) return(Out) } }else{ N<- 1 S0<- Ph-1 # 09.11.12 } Ak<- Ptcrv(N,Fk); Bk<- Ptcrv(N+1,Fk) Ah<- Ptcrv(N,Fh); Bh<- Ptcrv(N+1,Fh) Ph<- (1-S0)*Ah+S0*Bh Phc<- Cancoordpers(c(Ph,0)) Ahc<- Cancoordpers(c(Ah,0)) Bhc<- Cancoordpers(c(Bh,0)) Vp<- Phc-EyePoint Va<- Ak-EyePoint AB<- Bk-Ak Cp<- Crossprod(Vp,AB) Nmr<- Crossprod(Va,Vp) Mx<- max(abs(Cp)) if (abs(Cp[1])==Mx){ T2<- Nmr[1]/Cp[1] }else if (abs(Cp[2])==Mx){ T2<- Nmr[2]/Cp[2] }else{ T2<- Nmr[3]/Cp[3] } Pk<- (1-T2)*Ak+T2*Bk Out<- list(Pk,N+T2) return(Out) } ######################### Kukannozoku<- function(Jokyo,KukanL){ Eps<- 10^(-6) N<- Nrow(KukanL) T1<- Jokyo[1]; T2<- Jokyo[2] Tmp<- KukanL[1,] T1<- max(T1,Tmp[1]) Tmp<- KukanL[N,] T2<- min(T2,Tmp[2]) Res<- c() Flg<- 0 for (I in Looprange(1,N)){ Ku<- KukanL[I,] if (Flg==0){ if (Ku[2]T2+Eps){ Tmp<- c(T2,Ku[2]) Res<- rbind(Res,Tmp) } } }else if (Flg==1){ if (Ku[2]0){ for (J in 1:Mixlength(KC)){ P<- Op(1,Op(J,KC)) Tmp<- Op(2,Op(J,KC)) if (Tmp<1+Eps && Ns==1){ next } if (Tmp>Numptcrv(P1)-Eps && Ns==(Nrow(PhL)-1)){ next } N1<- Ns N2<- Op(3,Op(J,KC)) Pa<- Plt2[N1,1:2] Za<- Plt2[N1,3] Pb<- Plt2[N1+1,1:2] Zb<- Plt2[N1+1,3] if (Norm(Pa-Pb)Eps^2){ Tmp1<- P1[2,]-P1[1,] Tmp2<- Pb-Pa Tmp3<- Dotprod(Tmp1,Tmp2) Tmp3<- Tmp3/Norm(Tmp1)/Norm(Tmp2) Tmp<- 1-0.5*Tmp3^2 ClipL<- rbind(ClipL,c(P,N1,T1,R0/Tmp)) } } } } } } Te<- Nrow(Plt2) KukanL<- rbind(c(),c(1.0,Te)) P1<- PhL if (Nrow(ClipL)>0){ for (I in 1:Nrow(ClipL)){ P<- ClipL[I,1:2] NN<- ClipL[I,3] T<- NN+ClipL[I,4] R<- ClipL[I,5] Flg<- 0 for (J in NN:1){ Q<- Pointoncrv(J,P1) if (Norm(P-Q)Eps){ Tmp<- Pointoncrv(T2,P1) PtL<- c(PtL,list(Tmp)) } Res<- c(Res,list(Listplot(PtL))) } Allres<- c(Allres,Res) } return(Allres) } ######################### #100815 Makeskeletonpersdata<- function(Obj2L,Plt2L,R0,Eps2){ Eps<- 10.0^(-3) Dmat<- c() Dind<- c() for (I in Looprange(1,Mixlength(Plt2L))){ Dt<- Op(I,Plt2L) N1<- Nrow(Dmat)+1 Dmat<- rbind(Dmat,Dt) N2<- Nrow(Dmat) Dind<- rbind(Dind,c(N1,N2)) } Nind<- Nrow(Dind) Allres<- list() for (Nobj in Looprange(1,Mixlength(Obj2L))){ Plt2<- Op(Nobj,Obj2L) PhL<- Plt2[,1:2] ClipL<- c() for (Ns in Looprange(1,Nrow(PhL)-1)){ P1<- PhL[Ns:(Ns+1),] for (I in Looprange(1,Nrow(Dind))){ Tmp<- Dmat[Dind[I,1]:Dind[I,2],] P2<- Tmp[,1:2] KC<- IntersectcrvsPp(P1,P2,Eps) if (Mixlength(KC)>0){ for (J in Looprange(1,Mixlength(KC))){# P<- Op(1,Op(J,KC)) Tmp<- Op(2,Op(J,KC)) if (Tmp<(1+Eps) && Ns==1){ next } if (Tmp>Numptcrv(P1)-Eps && Ns==(Nrow(PhL)-1)){ next } N1<- Ns N2<- Op(3,Op(J,KC)) Pa<- Plt2[N1,1:2] Za<- Plt2[N1,3] Pb<- Plt2[N1+1,1:2] Zb<- Plt2[N1+1,3] if (Norm(Pa-Pb)1-Eps){ Pk<- Pkb }else{ Tmp1<- Listplot(c(Pa,Pb)) Tmp2<- Spaceline(c(Pka,Pkb)) Tmp<- Invperspt(1+T1,Tmp1,Tmp2) Pk<- Op(1,Tmp) } Z1<- Zperspt(Pk) Tmp<- Dmat[Dind[I,1]:Dind[I,2],] Pa<- Tmp[N2,1:2] Za<- Tmp[N2,3] Pb<- Tmp[N2+1,1:2] Zb<- Tmp[N2+1,3] if (Norm(Pa-Pb)(1-Eps)){ Pk<- Pkb }else{ Tmp1<- Listplot(c(Pa,Pb)) Tmp2<- Spaceline(c(Pka,Pkb)) Tmp<- Invperspt(1+T2,Tmp1,Tmp2) Pk<- Op(1,Tmp) } Z2<- Zperspt(Pk) if (Z1<(Z2-Eps2)){ if (length(ClipL)==0){ Tmp<- 1 }else{ Tmp1<- ClipL[,1]-P[1] Tmp2<- ClipL[,2]-P[2] Tmp3<- Tmp1^2+Tmp2^2 Tmp<- min(Tmp3) } if (Tmp>Eps^2){ Tmp1<- P1[2,]-P1[1,] Tmp2<- Pb-Pa Tmp3<- Dotprod(Tmp1,Tmp2) Tmp3<- Tmp3/Norm(Tmp1)/Norm(Tmp2) Tmp<- 1-0.5*Tmp3^2 ClipL<- rbind(ClipL,c(P,N1,T1,R0/Tmp)) } } } } } } Te<- Nrow(Plt2) KukanL<- rbind(c(),c(1.0,Te)) P1<- PhL if (Nrow(ClipL)>0){ for (I in Looprange(1,Nrow(ClipL))){ P<- ClipL[I,1:2] NN<- ClipL[I,3] T<- NN+ClipL[I,4] R<- ClipL[I,5] #added 10.08.17 Flg<- 0 for (J in NN:1){ Q<- Pointoncrv(J,P1) if (Norm(P-Q)Eps){ Tmp<- Pointoncrv(T2,P1) PtL<- c(PtL,list(Tmp))#Mixadd(PtL,Tmp) } Res<- c(Res,list(Listplot(PtL)))#Res<- Mixadd(Res,Listplot(PtL)) } Allres<- c(Allres,Res)#Allres<- Mixjoin(Allres,Res) } return(Allres) } ##############################3 MakeveLfaceL<- function(VfL){ # // Out format # // VeL Edge, Face num(as numlist), VeL num # // FL Face (Vertexs) Eps<- 10^(-4) Tmp<- VfL[[length(VfL)]] Tmp1<- Tmp[[1]] if (mode(Tmp1)=="numeric"){ FvL<- list(VfL) }else{ FvL<- VfL } EL<- list(); FL<- list() for (Nn in Looprange(1,length(FvL))){ Tmp<- FvL[[Nn]] VL<- Tmp[[1]] if (length(VL)>0){ FnL<- Tmp[[2]] FaceL<- list() for (I in Looprange(1,length(FnL))){ Tmp1<- FnL[[I]] PtL<- list() for (J in Looprange(1,length(Tmp1))){ Tmp2<- Tmp1[[J]] PtL[[J]]<- VL[[Tmp2]] } FaceL[[I]]<- PtL } }else{ FaceL<- list(Tmp[[2]]) } for (I in Looprange(1,length(FaceL))){ Face<- FaceL[[I]] Face<- c(Face,list(Face[[1]])) FL<- c(FL,list(Face)) for (J in Looprange(1,length(Face)-1)){ Edge<- list(Face[[J]],Face[[J+1]]) Flg<- 0 for (K in Looprange(1,length(EL))){ Tmp<- EL[[K]] Tmp1<- Tmp[[1]] Tmp2<- Norm(Edge[[1]]-Tmp1[[1]])+Norm(Edge[[2]]-Tmp1[[2]]) Tmp3<- Norm(Edge[[1]]-Tmp1[[2]])+Norm(Edge[[2]]-Tmp1[[1]]) if (Tmp21-Eps){# // P3, Q3 are necessary Flg<- I break } if (abs(Te-Ts)>Eps0){ if ((I%%2)==1){ Out1<- c(Out1,list(list(Pe3,P3))) }else{ if (length(Qe3)==0){ Tmp<- Op(2,TenL[[I-1]]) if (Ptype==-1){ Tmp1<- Invperspt(Tmp,Spaceline(Face)) }else{ Tmp1<- Invparapt(Tmp,Spaceline(Face)) } Qe3<- Tmp1[[1]] } PM<- 0.5*(Pe3+P3); QM<- 0.5*(Qe3+Q3) if (Ptype==-1){ Z1<- Zperspt(PM); Z2<- Zperspt(QM) }else{ Z1<- Zparapt(PM); Z2<- Zparapt(QM) } if (Z1>Z2){ Out1<- c(Out1, list(list(Pe3,P3))) }else{ Out2<- c(Out2, list(list(Pe3,P3))) }## } } Te<- Ts; Pe3<- P3; Qe3<- Q3 } if (Flg==0){ if (Norm(Pe3-Edge[[2]])>Eps0){ Out1<- c(Out1, list(list(Pe3,Edge[[2]]))) } }else{ if ((Flg%%2)==1){ Out1<- c(Out1, list(list(Pe3,Edge[[2]]))) }else{ PM<- 0.5*(Pe3+P3); QM<- 0.5*(Qe3+Q3) if (Ptype==-1){ Z1<- Zperspt(PM); Z2<- Zperspt(QM) }else{ Z1<- Zparapt(PM); Z2<- Zparapt(QM) } if (Z1>Z2){ Out1<- c(Out1, list(list(Pe3,Edge[[2]]))) }else{ Out2<- c(Out2, list(list(Pe3,Edge[[2]]))) } } } for (I in Looprange(1,length(Out1))){ Tmp<- Out1[[I]] if (I==1){ SeL<- Tmp }else{ if (Norm(SeL[[2]]-Tmp[[1]])0){ Out1L<- c(Out1L, list(list(SeL,Ne,NNe))) } for (I in Looprange(1,length(Out2))){ Tmp<- Out2[[I]] if (I==1){ SeL<- Tmp }else{ if (Norm(SeL[[2]]-Tmp[[1]])0){ Out2L<- c(Out2L, list(list(SeL,Ne,NNe))) } } VELNO<<- Out1L VELHI<<- Out2L } ################################### Parapt<- function(P){ x<- P[1] y<- P[2] z<- P[3] Xz<- -x*sin(PHI)+y*cos(PHI) Yz<- -x*cos(PHI)*cos(THETA)-y*sin(PHI)*cos(THETA)+z*sin(THETA) Out<- c(Xz,Yz) return(Out) } ################################### #100815 Partcrv3<- function(T1,T2,Fk){ Eps=10^(-4) #// Tmp=Mixop(1,Fk) #// new part from if (T1>(T2+Eps)){ Npt<- Nrow(Fk) Out1<- Partcrv3(T1,Npt,Fk) Out2<- Partcrv3(1,T2,Fk) Tmp<- Fk[1,]-Fk[Npt,] if (Norm(Tmp)(Ie+Eps)){ P<- (1-T2+Ie)*Fk[Ie,]+(T2-Ie)*Fk[Ie+1,] PL<- rbind(PL,P) } rownames(PL)<- 1:Nrow(PL) return(PL) } ################################### #100815 Partcrv3<- function(T1,T2,Fk){ Eps=10^(-4) #// Tmp=Mixop(1,Fk) #// new part from if (T1>(T2+Eps)){ Npt<- Nrow(Fk) Out1<- Partcrv3(T1,Npt,Fk) Out2<- Partcrv3(1,T2,Fk) Tmp<- Fk[1,]-Fk[Npt,] if (Norm(Tmp)(Ie+Eps)){ P<- (1-T2+Ie)*Fk[Ie,]+(T2-Ie)*Fk[Ie+1,] PL<- rbind(PL,P) } rownames(PL)<- 1:Nrow(PL) return(PL) } ################################### #100815 Perspt<- function(P){ Tmp<- P-FocusPoint X1<- Tmp[1]; Y1<- Tmp[2]; Z1<- Tmp[3] Tmp<- EyePoint-FocusPoint E1<- Tmp[1];F1<- Tmp[2];G1<- Tmp[3] Ca<- E1/sqrt(E1^2+F1^2) Sa<- F1/sqrt(E1^2+F1^2) X2<- X1*Ca+Y1*Sa; Y2<- -X1*Sa+Y1*Ca; Z2<- Z1 E2<- E1*Ca+F1*Sa; F2<- -E1*Sa+F1*Ca; G2<- G1 Cb<- E2/sqrt(E2^2+G2^2) Sb<- G2/sqrt(E2^2+G2^2) X3<- X2*Cb+Z2*Sb; Y3<- Y2; Z3<- -X2*Sb+Z2*Cb E3<- E2*Cb+G2*Sb; F3<- F2; G3<- -E2*Sb+G2*Cb Yz<- E3/(E3-X3)*Y3 Zz<- E3/(E3-X3)*Z3 Out<- c(Yz,Zz) return(Out) } ################################# Phcutdata<- function(VL,FaceL,PlaneD){ Out<- list() EL<- list() Eps<- 10^(-4) for (I in Looprange(1,Mixlength(FaceL))){ Face<- Op(I,FaceL) for (J in Looprange(1,length(Face))){ Nj<- J+1 if (J==length(Face)){ Nj<- 1 } N1<- Face[J]; N2<- Face[Nj] Tmp<- c(N1,N2) Flg<- 0 for (K in Looprange(1,Mixlength(EL))){ Tmp1<- Op(K,EL) Tmp2<- Tmp1[2:1] if (all(Tmp==Tmp1) || all(Tmp==Tmp2)){ Flg<- 1 break } } if (Flg==0){ EL<- c(EL,list(Tmp)) } } } Out0<- list() for (I in Looprange(1,Mixlength(EL))){ Tmp<- Op(I,EL) Tmp1<- Op(Tmp[1],VL) Tmp2<- Op(Tmp[2],VL) Out0<- c(Out0, list(Spaceline(Tmp1,Tmp2))) } if (Mixtype(PlaneD)!=1){ V1<- Op(1,PlaneD) Tmp<- Op(2,PlaneD) if (length(Tmp)>1){ d<- V1[1]*Tmp[1]+V1[2]*Tmp[2]+V1[3]*Tmp[3] }else{ d<- Tmp } }else if (mode(PlaneD)=="numeric"){ V1<- PlaneD[1:3] d<- PlaneD[4] }else{ StrV<- strsplit(PlaneD,"=",fixed=TRUE) StrV<- StrV[[1]] if(length(StrV)>1){ Tmp1<- StrV[1] Tmp2<- StrV[2] PlaneD<- paste(Tmp1,"-(",Tmp2,")",sep="") } x<- 0; y<- 0; z<- 0 d<- -eval(parse(text=PlaneD)) x<- 1; y<- 0; z<- 0; Tmp1<- eval(parse(text=PlaneD))+d x<- 0; y<- 1; z<- 0 Tmp2<- eval(parse(text=PlaneD))+d x<- 0; y<- 0; z<- 1 Tmp3<- eval(parse(text=PlaneD))+d V1<- c(Tmp1,Tmp2,Tmp3) } if (all(V1==c(0,0,0))){ return(Out0) } V3<- c(1,0,0) Out1<- Rotate3data(Out0,V1,V3) Tmp2<- Rotate3pt(c(1,0,0),V3,V1) Tmp<- V1[1]*Tmp2[1]+V1[2]*Tmp2[2]+V1[3]*Tmp2[3] x0<- d/Tmp PtL<- list() for (I in Looprange(1,Mixlength(Out1))){ Tmp<- Op(I,Out1) Tmp1<- Tmp[1,]; Tmp2<- Tmp[2,] P<- list(Tmp1,Tmp2-Tmp1) Tmp<- list(Tmp1[1],Tmp2[1]-Tmp1[1]) if (abs(Tmp[[2]]) < Eps){ Tmp<- c() }else{ Tmp1<- Tmp[[2]] Tmp2<- x0-Tmp[[1]] Tmp<- c(Tmp2/Tmp1) } if (length(Tmp)>0){ Tmp<- Tmp[1] if (Tmp>-Eps && Tmp<(1+Eps)){ Tmp3<- P[[1]]+Tmp*P[[2]] Tmp3<- Rotate3pt(Tmp3,V3,V1) if (Tmp1-Eps){ Tmp1<- Op(I,EL) Tmp1<- Tmp1[2] Tmp4<- list(c(Tmp1,Tmp1),Tmp3) }else{ Tmp4<- list(Op(I,EL),Tmp3) } } Flg<- 0 for (J in Looprange(1,Mixlength(PtL))){ Tmp<- Op(J,PtL) Tmp<- Op(2,Tmp) if (Norm(Tmp3-Tmp)1){ d<- V1[1]*Tmp[1]+V1[2]*Tmp[2]+V1[3]*Tmp[3] }else{ d<- Tmp } }else if (mode(PlaneD)=="numeric"){ V1<- PlaneD[1:3] d<- PlaneD[4] }else{ StrV<- strsplit(PlaneD,"=",fixed=TRUE) StrV<- StrV[[1]] if(length(StrV)>1){ Tmp1<- StrV[1] Tmp2<- StrV[2] PlaneD<- paste(Tmp1,"-(",Tmp2,")",sep="") } x<- 0; y<- 0; z<- 0 d<- -eval(parse(text=PlaneD)) x<- 1; y<- 0; z<- 0 Tmp1<- eval(parse(text=PlaneD))+d x<- 0; y<- 1; z<- 0 Tmp2<- eval(parse(text=PlaneD))+d x<- 0; y<- 0; z<- 1 Tmp3<- eval(parse(text=PlaneD))+d V1<- c(Tmp1,Tmp2,Tmp3) } for (I in Looprange(1,Mixlength(FaceL))){ Face<- Op(I,FaceL) TmpL<- list() for (J in Looprange(1,length(Face))){ N1<- Face[J] if (J==length(Face)){ N2<- Face[1] }else{ N2<- Face[J+1] } for (K in Looprange(1,Mixlength(PtL))){ Pd<- Op(K,PtL) Tmp<- Op(1,Pd) if (Tmp[1]==Tmp[2]){ if (Tmp[1]==N1){ TmpL<- c(TmpL,list(list(J,c(N1,N2),Op(2,Pd)))) } }else{ if (all(Tmp==c(N1,N2)) || all(Tmp==c(N2,N1))){ TmpL<- c(TmpL,list(list(J,c(N1,N2),Op(2,Pd)))) } } } } if (Mixlength(TmpL)<2){ Flg<- 0 for (J in Looprange(1,length(Face))){ Tmp<- Op(Face[J],VL) Tmp1<- Fugou*(Dotprod(V1,Tmp)-d) if (Tmp1< -Eps){ Flg<- 1 break } } if (Flg==0){ OutfL<- c(OutfL,list(Face)) } next } Pd<- Op(1,TmpL) Qd<- Op(2,TmpL) Outf1<- c(Op(3,Pd)) Nf<- Op(1,Pd)+1 Tmp<- Op(2,Pd) JJ<- 0 while (!all(Tmp==Op(2,Qd))){ JJ<- JJ+1 if (JJ>20){ print("bug") return() } Tmp1<- Tmp[2] if (Outf1[length(Outf1)]!=Tmp1){ Outf1<- c(Outf1,Tmp1) } Tmp<- c(Face[Nf]) Nf<- Nf+1 if (Nf>length(Face)){ Nf<- 1 } Tmp<- c(Tmp,Face[Nf]) } Tmp1<- Op(3,Qd) if (Outf1[length(Outf1)]!=Tmp1){ Outf1<- c(Outf1,Tmp1) } Outf2<- c(Op(3,Pd)) Nf<- Op(1,Pd) Tmp<- Op(2,Pd) JJ<- 0 while (!all(Tmp==Op(2,Qd))){ JJ<- JJ+1 if (JJ>20){ print("bug") return() } Tmp1<- Tmp[1] if (Outf2[length(Outf2)]!=Tmp1){ Outf2<- c(Outf2,Tmp1) } Tmp<- c(Face[Nf]) Nf<- Nf-1 if (Nf<1){ Nf<- length(Face) } Tmp<- c(Face[Nf],Tmp) } Tmp1<- Op(3,Qd) if (Outf2[length(Outf2)]!=Tmp1){ Outf2<- c(Outf2,Tmp1) } if (length(Outf1)<3 || length(Outf2)<3){ Face<- Outf1 if (length(Outf1)Eps){ AnsL<- c(AnsL,Tmp) } } } else{ AnsL<- c(AnsL,c(Inf,Inf)) } } AnsL<- matrix(AnsL,ncol=2,byrow=TRUE) return(AnsL) } #################################### Projpara<- function(...){ varargin<-list(...) Nargs<- length(varargin) Flg<- 0 if (Nargs==1 && Mixtype(varargin[[1]])==1){ Flg<- 1 } CL<- list() for (N in Looprange(1,Nargs)){ Crv<- varargin[[N]] if (Mixtype(Crv)==1){ Tmp<- ProjCurve(Crv) CL<- c(CL,list(Tmp)) } else{ if (Mixtype(Crv)==3){ ObjL<- list() for (I in Looprange(1,Mixlength(Crv))){ Tmp1<- Op(I,Crv) if (Mixtype(Tmp1)==1){ ObjL<- c(ObjL,list(Tmp1)) } else{ ObjL<- c(ObjL,Tmp1) } } Crv<- ObjL } for (J in Looprange(1,Mixlength(Crv))){ Tmp<- ProjCurve(Op(J,Crv)) CL<- c(CL,list(Tmp)) } } } if (Mixlength(CL)==1 && Flg==1){ CL<- Op(1,CL) } return(CL) } ######################### #100816 Projpers<- function(...){ varargin<- list(...) Nargs<- length(varargin) Flg<- 0 if (Nargs==1 && Mixtype(varargin[[1]])==1){ Flg<- 1 } CL<- list() for (N in Looprange(1,Nargs)){ Crv<- varargin[[N]] if (Mixtype(Crv)==1){ Tmp<- CameraCurve(Crv) CL<- c(CL,list(Tmp)) }else{ if (Mixtype(Crv)==3){ ObjL<- list() for (I in Looprange(1,Mixlength(Crv))){ Tmp1<- Op(I,Crv) if (Mixtype(Tmp1)==1){ ObjL<- c(ObjL,list(Tmp1)) }else{ ObjL<- c(ObjL,Tmp1) } } Crv<- ObjL } for (J in Looprange(1,Mixlength(Crv))){ Tmp<- CameraCurve(Op(J,Crv)) CL<- c(CL,list(Tmp)) } } } if (Mixlength(CL)==1 && Flg==1){ CL<- Op(1,CL) } return(CL) } ######################################### # 11.08.27 # 14.03.23 Debugged "center" Rotate3data<- function(...){ #Eps=10^(-4) varargin<-list(...) Nargs<- length(varargin) Pd3<- varargin[[1]] W1<- varargin[[2]] W2<- varargin[[3]] C<- c(0,0,0) if (Nargs>=4){ C<- varargin[[4]] } if (Mixtype(Pd3)==1){ Pd3<- list(Pd3) } else if (Mixtype(Pd3)==3){ Tmp<- list() for (I in Looprange(1,Mixlength(Pd3))){ Tmp<- c(Tmp,Op(I,Pd3)) } Pd3<- Tmp } Out<- list() for (I in Looprange(1,Mixlength(Pd3))){ PD<- Op(I,Pd3) Ans<- c() for (J in Looprange(1,Nrow(PD))){ if(is.matrix(PD)){ # 11.08.27 P<- PD[J,] } else{ P<- PD } Tmp<- Rotate3pt(P,W1,W2,C) # 14.03.23 Ans<- rbind(Ans,Tmp) } # 11.08.27 rownames(Ans)<- 1:Nrow(Ans) #10.08.16 Out<- c(Out,list(Ans)) } if (Mixlength(Out)==1){ Out<- Op(1,Out) } return(Out) } ####################################### Rotate3pt<- function(...){ varargin<-list(...) Eps<-10^(-4) Nargs<-length(varargin) P<- varargin[[1]] W1<- varargin[[2]] W2<- varargin[[3]] C<- c(0,0,0) if (Nargs>=4){ C<- varargin[[4]] } if (mode(W2)=="numeric" && length(W2)==1){ Ct<- cos(W2) St<- sin(W2) V3<- 1/Norm(W1)*W1 if (V3[1]==0){ Tmp<- c(1,0,0) }else{ Tmp<- c(0,1,0) } W1<- c(Tmp[2]*V3[3]-Tmp[3]*V3[2], Tmp[3]*V3[1]-Tmp[1]*V3[3], Tmp[1]*V3[2]-Tmp[2]*V3[1]) V1<- 1/Norm(W1)*W1 V2<- c(V3[2]*V1[3]-V3[3]*V1[2], V3[3]*V1[1]-V3[1]*V1[3], V3[1]*V1[2]-V3[2]*V1[1]) }else{ Tmp<- c(W1[2]*W2[3]-W1[3]*W2[2], W1[3]*W2[1]-W1[1]*W2[3], W1[1]*W2[2]-W1[2]*W2[1]) if (Norm(Tmp)=3){ Ndu<- varargin[[2]] Ndv<- varargin[[3]] } if (Nargs>=4){ Np<- varargin[[4]] if (mode(Np)=="numeric" && length(Np)==1){ Np<- c(Np,Np) } } Du<- (Umax-Umin)/Ndu Dv<- (Vmax-Vmin)/Ndv PL <- c()#PL <- [] Assign("Vmin",Vmin,"Vmax",Vmax) Trgstr<- Assign("t=c(Vmin,Vmax)") PL <- list() for (I in Looprange(0,Ndu)){ U0 <- paste("(",as.character(Umin+I*Du),")",sep="") Tmp<- gsub(U,U0,Xf,fixed=TRUE) Tmp1<- gsub(V,"t",Tmp,fixed=TRUE) Tmp<- gsub(U,U0,Yf,fixed=TRUE) Tmp2<- gsub(V,"t",Tmp,fixed=TRUE) Tmp<- gsub(U,U0,Zf,fixed=TRUE) Tmp3<- gsub(V,"t",Tmp,fixed=TRUE) Tmp<- paste("c(",Tmp1,",",Tmp2,",",Tmp3,")",sep="") PD<- Spacecurve(Tmp,Trgstr,paste("N=",as.character(Np[2]))) PL<- c(PL,list(PD)) } Assign("Umin",Umin,"Umax",Umax) Trgstr<- Assign("t=c(Umin,Umax)") for (J in Looprange(0,Ndv)){ V0<- paste("(",as.character(Vmin+J*Dv),")",sep="") Tmp<- gsub(V,V0,Xf,fixed=TRUE) Tmp1<- gsub(U,"t",Tmp,fixed=TRUE) Tmp<- gsub(V,V0,Yf,fixed=TRUE) Tmp2<- gsub(U,"t",Tmp,fixed=TRUE) Tmp<- gsub(V,V0,Zf,fixed=TRUE) Tmp3<- gsub(U,"t",Tmp,fixed=TRUE) Tmp<- paste("c(",Tmp1,",",Tmp2,",",Tmp3,")") PD<- Spacecurve(Tmp,Trgstr,paste("N=",as.character(Np[1]))) PL<- c(PL,list(PD)) } return(PL) } ################################### Skeletonparadata<- function(...){ varargin<-list(...) Nargs<- length(varargin) Out<- list() ObjL<- Flattenlist(varargin[[1]]) Plt3L<- Flattenlist(varargin[[2]]) R<- 0.075*1000/2.54/MilliIn if (Nargs>2){ R<- R*varargin[[3]] } Eps2<- 0.05 if (Nargs>3){ Eps2<- varargin[[4]] } Obj2L<- list() for (I in Looprange(1,Mixlength(ObjL))){ Tmp<- ProjcoordCurve(Op(I,ObjL)) Obj2L<- c(Obj2L,list(Tmp)) } Plt2L<- list() for (I in Looprange(1,Mixlength(Plt3L))){ Tmp<- ProjcoordCurve(Op(I,Plt3L)) Plt2L<- c(Plt2L,list(Tmp)) } Out<- Makeskeletondata(Obj2L,Plt2L,R,Eps2) return(Out) } ################################ Skeletonpara3data<- function(...){ varargin<-list(...) Nargs<- length(varargin) ObjL<- Flattenlist(varargin[[1]]) Plt3L<- Flattenlist(varargin[[2]]) R<- 0.075*1000/2.54/MilliIn if (Nargs>2){ R=R*varargin[[3]] } Eps2<- 0.05 if (Nargs>3){ Eps2<- varargin[[4]] } Plt2L<- list() for (I in Looprange(1,Mixlength(Plt3L))){ Tmp<- ProjcoordCurve(Op(I,Plt3L)) Plt2L<- c(Plt2L,list(Tmp)) } Out<- list() for (I in Looprange(1,Mixlength(ObjL))){ Obj3<- Op(I,ObjL) Tmp<- ProjcoordCurve(Obj3) Data<- Makeskeletondata(list(Tmp),Plt2L,R,Eps2) for (J in Looprange(1,Mixlength(Data))){ Gd<- Op(J,Data) PtD<- c() for (J in Looprange(1,Nrow(Gd))){ Tmp<- Ptcrv(J,Gd) Tmp1<- Invparapt(Tmp,Obj3) Tmp1<- Op(1,Tmp1) PtD<- c(PtD,Tmp1) } PtD<- matrix(PtD,ncol=3,byrow=TRUE) Out<- c(Out,list(PtD)) } } return(Out) } ################################# #100815 Skeletonpersdata<- function(...){ varargin<-list(...) Nargs<- length(varargin) Out<- list() ObjL<- Flattenlist(varargin[[1]]) Plt3L<- Flattenlist(varargin[[2]]) R<- 0.075*1000/2.54/MilliIn if (Nargs>2){ R<- R*varargin[[3]] } Eps2<- 0.05 if (Nargs>3){ Eps2<- varargin[[4]] } Obj2L<- list() for (I in Looprange(1,Mixlength(ObjL))){ Tmp<- CameracoordCurve(Op(I,ObjL)) Obj2L<- c(Obj2L,list(Tmp)) } Plt2L<- list() for (I in Looprange(1,Mixlength(Plt3L))){ Tmp<- CameracoordCurve(Op(I,Plt3L)) Plt2L<- c(Plt2L,list(Tmp)) } Out<- Makeskeletonpersdata(Obj2L,Plt2L,R,Eps2) return(Out) } ##################### #100815 Skeletonpers3data<- function(...){ varargin<-list(...) Nargs<- length(varargin) Out<- list() ObjL<- Flattenlist(varargin[[1]]) Plt3L<- Flattenlist(varargin[[2]]) R<- 0.075*1000/2.54/MilliIn if (Nargs>2){ R<- R*varargin[[3]] } Eps2<- 0.05 if (Nargs>3){ Eps2<- varargin[[4]] } Plt2L<- list() for (I in Looprange(1,Mixlength(Plt3L))){ Tmp<- CameracoordCurve(Op(I,Plt3L)) Plt2L<- c(Plt2L,list(Tmp)) } Out<- list() for (I in Looprange(1,Mixlength(ObjL))){ Obj3<- Op(I,ObjL) Tmp<- CameracoordCurve(Obj3) Data<- Makeskeletonpersdata(list(Tmp),Plt2L,R,Eps2) for (J in Looprange(1,Mixlength(Data))){ Gd<- Op(J,Data) PtD<- c() for (J in Looprange(1,Nrow(Gd))){ Tmp<- Gd[J,] Tmp1<- Invperspt(Tmp,Obj3) Tmp1<- Op(1,Tmp1) PtD<- rbind(PtD,Tmp1) } Out<- c(Out,list(PtD)) } } return(Out) } ################################# Spacecurve<- function(...){ Eps<- 10^(-5) varargin<-list(...) Nargs<- length(varargin) Fnstr<- varargin[[1]] Rgstr<- varargin[[2]] Range<- c(0,2*pi) N<- 50 #Numpoints E<- c() #Exclusions D<- Inf #Discont (Changed) for(I in Looprange(3,Nargs)){ Tmp<- varargin[[I]] StrV<- strsplit(Tmp,"=",fixed=TRUE) StrV<- StrV[[1]] Tmp1<- toupper(StrV[1]) Lhs<- substr(Tmp1,1,1) Str<- paste(Lhs,"=",StrV[2]) eval(parse(text=Str)) } StrV<- strsplit(Rgstr,"=",fixed=TRUE) StrV<- StrV[[1]] if (length(StrV)>1){ Vname<- StrV[1] Rng<- eval(parse(text=StrV[2])) } else{ Vname<- Rgstr Rng<- c(XMIN,XMAX) } T1<- Rng[1]; T2<- Rng[2] Dt<- (T2-T1)/N #17.09.22 Str<- gsub(Vname,"t",Fnstr) P<- c() # E<- sort(E,decreasing=FALSE) E<- c(E,Inf) E<- sort(E,decreasing=FALSE) Ke<- 1 t<- T1 while(t0 && P[Nrow(P),1]!=Inf){ Pa<- c(Inf,Inf,Inf) } } if (t-E[Ke]>Eps){ Pa<- eval(parse(text=Str)) Ke<- Ke+1 } if (length(Pa)>0){ if (Pa[1]==Inf){ P<- rbind(P,Pa) }else if (length(P)==0){ P<- rbind(c(),c(Pa)) } else{ Tmp<- P[Nrow(P),] if (Tmp[1]==Inf){ P<- rbind(P,Pa) } else if( Norm(Tmp-Pa)1) StrV<- StrV[2] Tmp<- eval(parse(text=StrV)) Py<- c(0,Tmp[1],0) Qy<- c(0,Tmp[2],0) StrV<-strsplit(Zrange,"=",fixed=TRUE) StrV<- StrV[[1]] if(length(StrV)>1) StrV<- StrV[2] Tmp<- eval(parse(text=StrV)) Pz<- c(0,0,Tmp[1]) Qz<- c(0,0,Tmp[2]) Out<- list(Spaceline(Px,Qx),Spaceline(Py,Qy),Spaceline(Pz,Qz)) return(Out) } ################################### Xyzaxparaname<- function(...){ varargin<- list(...) Nargs<- length(varargin) Eps<- 10.0^(-6) Dr<- 0.19*1000/2.54/MilliIn Tmp<- varargin[[Nargs]] if (Nargs>1 && is.numeric(Tmp)){ Dr<- Dr*Tmp Nargs<- Nargs-1 } if (mode(varargin[[1]])=="character"){ Xname<- "x" Yname<- "y" Zname<- "z" Xrange<- varargin[[1]] Yrange<- varargin[[2]] Zrange<- varargin[[3]] StrV<-strsplit(Xrange,"=",fixed=TRUE) StrV<- StrV[[1]] if(length(StrV)>1){ Xname<- StrV[1] StrV<- StrV[2] } Tmp<- eval(parse(text=StrV)) Px<- c(Tmp[1],0,0) Qx<- c(Tmp[2],0,0) StrV<-strsplit(Yrange,"=",fixed=TRUE) StrV<- StrV[[1]] if(length(StrV)>1){ Yname<- StrV[1] StrV<- StrV[2] } Tmp<- eval(parse(text=StrV)) Py<- c(0,Tmp[1],0) Qy<- c(0,Tmp[2],0) StrV<-strsplit(Zrange,"=",fixed=TRUE) StrV<- StrV[[1]] if(length(StrV)>1){ Zname<- StrV[1] StrV<- StrV[2] } Tmp<- eval(parse(text=StrV)) Pz<- c(0,0,Tmp[1]) Qz<- c(0,0,Tmp[2]) }else{ Data<- varargin[[1]] Xname<- "x"; Yname<- "y"; Zname<- "z" if (Nargs>1){ if (varargin[[2]]!=""){ Xname<- varargin[[2]] } if (varargin[[3]]!=""){ Yname<- varargin[[3]] } if (varargin[[4]]!=""){ Zname<- varargin[[4]] } } Tmp<- Op(1,Data) Px<- Tmp[1,]; Qx<- Tmp[2,] Tmp<- Op(2,Data) Py<- Tmp[1,] Qy<- Tmp[2,] Tmp<- Op(3,Data) Pz<- Tmp[1,] Qz<- Tmp[2,] } Ph<- Parapt(Px); Qh<- Parapt(Qx); R<-Norm(Ph-Qh) Kekka<- list() if (R>Eps){ Ch<- Qh+Dr/R*(Qh-Ph) Kekka<- c(Kekka,list(Pointdata(Ch))) Expr(Ch,"c",Xname) } Ph<- Parapt(Py); Qh<- Parapt(Qy); R<- Norm(Ph-Qh) if (R>Eps){ Ch<- Qh+Dr/R*(Qh-Ph) Kekka<- c(Kekka,list(Pointdata(Ch))) Expr(Ch,"c",Yname) } Ph<- Parapt(Pz); Qh<- Parapt(Qz); R<- Norm(Ph-Qh) if (R>Eps){ Ch<- Qh+Dr/R*(Qh-Ph) Kekka<- c(Kekka,list(Pointdata(Ch))) Expr(Ch,"c",Zname) } # return(Kekka) } ################################### Xyzaxpersname<- function(...){ varargin<- list(...) Eps<- 10.0^(-6) Nargs<- length(varargin) Dr<- 0.19*1000/2.54/MilliIn Tmp<- varargin[[Nargs]] if (Nargs>1 && mode(Tmp)=="numeric"){ Dr<- Dr*Tmp Nargs<- Nargs-1 } if (mode(varargin[[1]])=="character"){ Xname<- "x" Yname<- "y" Zname<- "z" Xrange<- varargin[[1]] Yrange<- varargin[[2]] Zrange<- varargin[[3]] StrV<-strsplit(Xrange,"=",fixed=TRUE) StrV<- StrV[[1]] if(length(StrV)>1){ Xname<- StrV[1] StrV<- StrV[2] } Tmp<- eval(parse(text=StrV)) Px<- c(Tmp[1],0,0) Qx<- c(Tmp[2],0,0) StrV<-strsplit(Yrange,"=",fixed=TRUE) StrV<- StrV[[1]] if(length(StrV)>1){ Yname<- StrV[1] StrV<- StrV[2] } Tmp<- eval(parse(text=StrV)) Py<- c(0,Tmp[1],0) Qy<- c(0,Tmp[2],0) StrV<-strsplit(Zrange,"=",fixed=TRUE) StrV<- StrV[[1]] if(length(StrV)>1){ Zname<- StrV[1] StrV<- StrV[2] } Tmp<- eval(parse(text=StrV)) Pz<- c(0,0,Tmp[1]) Qz<- c(0,0,Tmp[2]) }else{ Data<- varargin[[1]] Xname<- "x"; Yname<- "y"; Zname<- "z" if (Nargs>1){ if (varargin[[2]]!=""){ Xname<- varargin[[2]] } if (varargin[[3]]!=""){ Yname<- varargin[[3]] } if (varargin[[4]]!=""){ Zname<- varargin[[4]] } } Tmp<- Op(1,Data) Px<- Tmp[1,]; Qx<- Tmp[2,] Tmp<- Op(2,Data) Py<- Tmp[1,] Qy<- Tmp[2,] Tmp<- Op(3,Data) Pz<- Tmp[1,] Qz<- Tmp[2,] } Ph<- Perspt(Px) Qh<- Perspt(Qx) R<- Norm(Ph-Qh) Kekka<- list() if (R>Eps){ Ch<- Qh+Dr/R*(Qh-Ph) Kekka<- c(Kekka,list(Pointdata(Ch))) Expr(Ch,"c",Xname) } Ph<- Perspt(Py) Qh<- Perspt(Qy) R<- Norm(Ph-Qh) if (R>Eps){ Ch<- Qh+Dr/R*(Qh-Ph) Kekka<- c(Kekka,list(Pointdata(Ch))) Expr(Ch,"c",Yname) } Ph<- Perspt(Pz) Qh<- Perspt(Qz) R<- Norm(Ph-Qh) if (R>Eps){ Ch<- Qh+Dr/R*(Qh-Ph) Kekka<- c(Kekka,list(Pointdata(Ch))) Expr(Ch,"c",Zname) } # return(Kekka) } ######################### #100815 Zparapt<- function(P){#function Out=Zparapt(P) x<- P[1]; y<- P[2]; z<- P[3] Out<- x*cos(PHI)*sin(THETA)+y*sin(PHI)*sin(THETA)+z*cos(THETA) return(Out) } ######################### #100815 Zperspt<- function(P){ Tmp<- P-FocusPoint X1<- Tmp[1]; Y1<- Tmp[2]; Z1<- Tmp[3] Tmp<- EyePoint-FocusPoint E1<- Tmp[1]; F1<- Tmp[2]; G1<- Tmp[3] Ca<- E1/sqrt(E1^2+F1^2) Sa<- F1/sqrt(E1^2+F1^2) X2<- X1*Ca+Y1*Sa; Y2<- -X1*Sa+Y1*Ca; Z2<- Z1 E2<- E1*Ca+F1*Sa; F2<- -E1*Sa+F1*Ca; G2<- G1 Cb<- E2/sqrt(E2^2+G2^2) Sb<- G2/sqrt(E2^2+G2^2) X3<- X2*Cb+Z2*Sb return(X3) } ########################################## ########################################## # Stat Package ########################################## # 2010.04.12 # new # Htickmarklower, Vtickmarkleft, HtickmarklowerV # VtickmarkleftV, Insertcom, Replacecom # Maketexfile, Formatting # Drwhistframe, Histplotdata, Drwhistplot Htickmarklower<- function(...) { ## Scaling is implemented varargin<- list(...) Nargs<- length(varargin) ArgsL<- varargin if (mode(ArgsL[[1]])=="character"){ Str<- ArgsL[[1]] Tmp<- strsplit(Str,"m") Tmp<- Tmp[[1]] if (length(Tmp)>1){ I<- nchar(Tmp[1])+1 } else{ I<- 0 } Tmp<- strsplit(Str,"n") Tmp<- Tmp[[1]] if (length(Tmp)>1){ J<- nchar(Tmp[1])+1 } else{ J<- 0 } Tmp<- strsplit(Str,"r") Tmp<- Tmp[[1]] if (length(Tmp)>1){ K=nchar(Tmp[1])+1 } else{ K<- 0 } if (K>0){ S<- substr(Str,K+1,nchar(Str)) R<- as.numeric(S) if (is.na(R)){ R<- 1 } } else{ R<- 1 K<- nchar(Str)+1 } if (J>0){ S<- substr(Str,J+1,K-1) Dn<- as.numeric(S) if (is.na(Dn)){ Dn<- 1 } } else{ Dn<- 1000 J<- nchar(Str)+1 } S<- substr(Str,I+1,J-1) Dm<- as.numeric(S) if (is.na(Dm)){ Dm<- 1 } ArgsL<- list() for (I in Looprange(1, floor((XMAX-GENTEN[1])/Dm))){ ArgsL<- Mixjoin(ArgsL,I*Dm) if (I-floor(I/Dn)*Dn==0){ Str<- as.character(I*Dm*R) ArgsL<- Mixjoin(ArgsL,Str) } } for (I in seq(-1,ceiling((XMIN-GENTEN[1])/Dm),by=-1)){ ArgsL<- Mixjoin(ArgsL,I*Dm) if (I-floor(I/Dn)*Dn==0){ Str<- as.character(I*Dm*R) ArgsL<- Mixjoin(ArgsL,Str) } } } MemoriList<- list() Memori<- list() for (N in 1:length(ArgsL)){ Dt<- ArgsL[[N]] if (mode(Dt)=="numeric" && length(Dt)>1){ if (length(Memori)>0){ MemoriList<- Mixjoin(MemoriList,list(Memori)) } Memori<- list(Dt) next } if (mode(Dt)=="character"){ Memori<- Mixjoin(Memori,Dt) } else{ if (length(Memori)>0){ MemoriList<- Mixjoin(MemoriList,list(Memori)) } Memori<- list(Dt,GENTEN[2]) } } MemoriList<- Mixjoin(MemoriList,list(Memori)) for (N in 1:length(MemoriList)){ Dt<- MemoriList[[N]] Ndt<- length(Dt) X=Op(1,Dt) Y=Op(2,Dt) Tmp<-Doscaling(c(X,Y)) X<- Tmp[1] Y<- Tmp[2] Moji<- Op(Ndt,Dt) Tmp1<- Unscaling(c(X,Y)) Tmp2<- Unscaling(c(X,Y-2*MARKLEN)) Fd<- Listplot(c(Tmp1,Tmp2)) Drwline(Fd) if (Ndt==3){ Tmp<-Unscaling(c(X,Y-2*MARKLEN)) Expr(Tmp,"s",Moji) } if (Ndt==4){ Houkou<- Op(3,Dt) Tmp<-grep("s",Houkou) if (length(Tmp)>0){ Tmp<-Unscaling(c(X,Y-2*MARKLEN)) Expr(Tmp,Houkou,Moji) } else{ Tmp<- Unscaling(c(X,Y)) Expr(Tmp,Houkou,Moji) } } cat("%\n",file=Wfile,append=TRUE) } } Vtickmarkleft<- function(...) { ## Scaling is implemented varargin<- list(...) Nargs<- length(varargin) ArgsL<- varargin if (mode(ArgsL[[1]])=="character"){ Str<- ArgsL[[1]] Tmp<- strsplit(Str,"m") Tmp<- Tmp[[1]] if (length(Tmp)>1){ I<- nchar(Tmp[1])+1 } else{ I<- 0 } Tmp<- strsplit(Str,"n") Tmp<- Tmp[[1]] if (length(Tmp)>1){ J<- nchar(Tmp[1])+1 } else{ J<- 0 } Tmp<- strsplit(Str,"r") Tmp<- Tmp[[1]] if (length(Tmp)>1){ K=nchar(Tmp[1])+1 } else{ K<- 0 } if (K>0){ S<- substr(Str,K+1,nchar(Str)) R<- as.numeric(S) if (is.na(R)){ R<- 1 } } else{ R<- 1 K<- nchar(Str)+1 } if (J>0){ S<- substr(Str,J+1,K-1) Dn<- as.numeric(S) if (is.na(Dn)){ Dn<- 1 } } else{ Dn<- 1000 J<- nchar(Str)+1 } S<- substr(Str,I+1,J-1) Dm<- as.numeric(S) if (is.na(Dm)){ Dm<- 1 } ArgsL<- list() for (I in 1:floor((YMAX-GENTEN[2])/Dm)){ ArgsL<- Mixjoin(ArgsL,I*Dm) if (I-floor(I/Dn)*Dn==0){ Str<- as.character(I*Dm*R) ArgsL<- Mixjoin(ArgsL,Str) } } for (I in seq(-1,ceiling((YMIN-GENTEN[2])/Dm))){ ArgsL<- Mixjoin(ArgsL,I*Dm) if (I-floor(I/Dn)*Dn==0){ Str<- as.character(I*Dm*R) ArgsL<- Mixjoin(ArgsL,Str) } } } MemoriList<- list() Memori<- list() for (N in 1:length(ArgsL)){ Dt<- ArgsL[[N]] if (mode(Dt)=="numeric" && length(Dt)>1){ if (length(Memori)>0){ MemoriList<- Mixjoin(MemoriList,list(Memori)) } Memori<- list(Dt) next } if (mode(Dt)=="character"){ Memori<- Mixjoin(Memori,Dt) } else{ if (length(Memori)>0){ MemoriList<- Mixjoin(MemoriList,list(Memori)) } Memori<- list(GENTEN[1],Dt) } } MemoriList<- Mixjoin(MemoriList,list(Memori)) for (N in 1:length(MemoriList)){ Dt<- MemoriList[[N]] Ndt<- length(Dt) X=Op(1,Dt) Y=Op(2,Dt) Tmp<-Doscaling(c(X,Y)) X<- Tmp[1] Y<- Tmp[2] Moji<- Op(Ndt,Dt) Tmp1<- Unscaling(c(X,Y)) Tmp2<- Unscaling(c(X-2*MARKLEN,Y)) Fd<- Listplot(c(Tmp1,Tmp2)) Drwline(Fd) if (Ndt==3){ Tmp<-Unscaling(c(X-2*MARKLEN,Y)) Expr(Tmp,"w",Moji) } if (Ndt==4){ Houkou<- Op(3,Dt) Tmp<-grep("w",Houkou) if (length(Tmp)>0){ Tmp<-Unscaling(c(X-2*MARKLEN,Y)) Expr(Tmp,Houkou,Moji) } else{ Tmp<- Unscaling(c(X,Y)) Expr(Tmp,Houkou,Moji) } } cat("%\n",file=Wfile,append=TRUE) } } HtickmarklowerV<- function(Vec,digits=2,nsmall=2) { for (I in 1:length(Vec)){ Tmp<- Vec[I] Htickmarklower(Tmp, Formatting(Tmp,digits,nsmall)) } } HtickLV<- function(...) { HtickmarklowerV(...) } VtickmarkleftV<- function(Vec,digits=2,nsmall=2) { for (I in 1:length(Vec)){ Tmp<- Vec[I] Vtickmarkleft(Tmp, Formatting(Tmp,digits,nsmall)) } } VtickLV<- function(...) { VtickmarkleftV(...) } Insertcom<- function(CmdM,Npos,Str) { if (is.matrix(CmdM)){ Cmd<- CmdM } else{ C<- paste("Cmd<- ",CmdM) eval(parse(text=C)) } Out<- Cmd[Looprange(1,Npos-1),] Out<- c(Out,Str) Tmp<- Cmd[Looprange(Npos,nrow(Cmd)),] Out<- c(Out,Tmp) Out<- matrix(Out) if (!is.matrix(CmdM)){ C<- paste(CmdM,"<<- Out") eval(parse(text=C)) } return(Out) } Replacecom<- function(CmdM,Npos,Str) { if (is.matrix(CmdM)){ Cmd<- CmdM } else{ C<- paste("Cmd<- ",CmdM) eval(parse(text=C)) } Out<- Cmd[Looprange(1,Npos-1),] Out<- c(Out,Str) Tmp<- Cmd[Looprange(Npos+1,nrow(Cmd)),] Out<- c(Out,Tmp) Out<- matrix(Out) if (!is.matrix(CmdM)){ C<- paste(CmdM,"<<- Out") eval(parse(text=C)) } return(Out) } Deletecom<- function(CmdM,Npos) { if (is.matrix(CmdM)){ Cmd<- CmdM } else{ C<- paste("Cmd<- ",CmdM) eval(parse(text=C)) } Out<- Cmd[Looprange(1,Npos-1),] Tmp<- Cmd[Looprange(Npos+1,nrow(Cmd)),] Out<- c(Out,Tmp) Out<- matrix(Out) if (!is.matrix(CmdM)){ C<- paste(CmdM,"<<- Out") eval(parse(text=C)) } return(Out) } Maketexfile<- function(commands="",texfile="") { Openfile(texfile) Execmd(commands) Closefile() } Formatting<- function(X,D=2,N=2) { if (D>0){ Xs <- format(X,digits=D,nsmall=N) } else{ Xs<- as.character(X) } return(Xs) } ################################ Boxplotdata1 <-function(DataF1,CenterX,Width,...) { Xr <- Width Temp <- boxplot(DataF1[1],plot=FALSE) Stats <- Temp$stats rownames(Stats) <- c("Lhige","Q1","Q2","Q3","Uhige") Out <- Temp$out Lhige <- Stats["Lhige",1] Uhige <- Stats["Uhige",1] Q1 <- Stats["Q1",1] Q2 <- Stats["Q2",1] Q3 <- Stats["Q3",1] CenterY <- (Q1+Q3)/2 C <- c(CenterX,CenterY) V <- c(0,(Q3-Q1)/2) G1 <- Framedata(C,Xr/2,V[2]) # box Temp1 <- c(0,Q1-Lhige) Temp2 <- c(0,Uhige-Q3) G2 <- Listplot(C-V,C-V-Temp1) # G3 <- Listplot(C+V,C+V+Temp2) # Temp3 <- c(Xr/4,0) G4 <- Listplot(C-V-Temp1-Temp3,C-V-Temp1+Temp3) # G5 <- Listplot(C+V+Temp2-Temp3,C+V+Temp2+Temp3) # Temp4 <- c(0,Q3-Q2) Temp5 <- c(Xr/2,0) G6 <- Listplot(C+V-Temp4-Temp5,C+V-Temp4+Temp5) # G7 <- list() for(j in Looprange(1,length(Out))){ G7 <- c(G7,list(c(CenterX, Out[j]))) } G7 <- G7[order(Out,decreasing=TRUE)] list(median=G6,box=G1,uwhisker=G2,lwhisker=G3,lwp=G4,uwp=G5,outliers=G7) } Boxplotdata2 <- function(Data,Ratio, ...) { DataF<- Flattenlist(Data) # 11.07.21(from) ymin<- Inf ymax<- -Inf for(J in 1:length(DataF)){ Tmp<- DataF[[J]] ymin<- min(ymin, min(Tmp)) ymax<- max(ymax,max(Tmp)) } # 11.07.21(upto) dy <- ymax-ymin Setwindow(c(0,XMAX-XMIN),c(ymin-0.1*dy,ymax+0.1*dy)) R1<- (YMAX-YMIN)/(XMAX-XMIN) R<- Ratio/R1 Setscaling(R) Delta <- XMAX/length(DataF) W <- 0.6*Delta PdL <- list() for(i in 1:length(DataF)){ # 11.07.21 X <- (0.5+i-1)*Delta G <- Boxplotdata1(DataF[i],X,W,...) PdL <- c(PdL,list(G)) } G <- Framedata() Tmp<- list(frame=G) PdL <-c(PdL,list(Tmp)) Epsi <-0 Setwindow(c(XMIN-Epsi,XMAX+Epsi),c(YMIN-Epsi,YMAX+Epsi)) return(PdL) } Drwboxframe<-function(BoxDataL) { Setorigin(c(XMIN,YMIN)) Tmp<- Unscaling(c(0.2,0.2)) Setwindow(c(XMIN-0.2,XMAX),c(YMIN-Tmp[2],YMAX)) Hako<- BoxDataL$plotdata title<- BoxDataL$title cap<- BoxDataL$cap ylab<- BoxDataL$ylab if(mode(title)!="list") title<- list(title) if(mode(cap)!="list") cap<- list(cap) if(mode(ylab)!="list") ylab<- list(ylab) if(length(title)==0) title<- list("") if(length(title)==1) title<- c(title, list("n")) if(length(title)==2) title<- c(title, list("")) if(length(cap)==0) cap<- list("") if(length(cap)==1) cap<- c(cap, list("n"),0) # 11.11.27 if(length(cap)==2) cap<- c(cap, 0) # 11.11.27 if(length(ylab)==0) ylab<- list("") if(length(ylab)==1) ylab <- c(ylab, list("n")) if(length(ylab)==2) ylab<- c(ylab, list("")) Temp <- Hako[[length(Hako)]] Drwline(Temp$frame) Fontsize(cap[[2]]) for(i in Looprange(1,length(Hako)-1)){ Temp <- Hako[[i]] attach(Temp) Dashline(uwhisker,lwhisker) Drwline(median,2) Drwline(box,lwp,uwp) Drwpt(outliers,0) X <- uwhisker[1,1] detach(Temp) Htickmarklower(X) if(nchar(cap[[1]])<1) next # 2011.03.08 if(length(cap)==2 || cap[[3]]==0){ pos<- 1 if(length(cap)>=4) pos<- cap[[4]] Tmp<- paste("s",as.character(pos),sep="") Letter(c(X,YMIN),Tmp, Op(i,cap[[1]])) } else{ rotate<- cap[[3]] if(length(cap)==3){ pos<- 0 } else{ pos<- cap[[4]] } Temp1 <- rotate*pi/180 Temp <- c(cos(Temp1),sin(Temp1)) Letterrot(c(X,YMIN-pos),Temp,Op(i,cap[[1]])) } } if(nchar(ylab[[1]])>0){ Fontsize(ylab[[2]]) Tmp1<- ylab[[1]] Tmp3<- ylab[[3]] if(nchar(Tmp3)>0){ Tmp1<- paste("{\\",Tmp3," ",Tmp1,"}",sep="") } Letter(c(XMIN, YMAX),"n2",Tmp1) Fontsize("n") } if(nchar(title[[1]])>0){ Fontsize(title[[2]]) Tmp1<- title[[1]] Tmp3<- title[[3]] if(nchar(Tmp3)>0){ Tmp1<- paste("{\\",Tmp3," ",Tmp1,"}",sep="") } Letter(c((XMIN+XMAX)/2,YMAX),"n2",Tmp1) } Fontsize("n") } Drwboxplot<- function(dataf,var,size, title=list(""), cap=list(colnames(dataf)), ylab=list(""), ptsize=5,plot=TRUE,...) #Return : title,cap,ylab,commands,plotdata,info { Tmp <- boxplot(dataf, plot=FALSE, ...) Stats <- Tmp$stats DataF<- Flattenlist(dataf) # 11.07.21(from) ymin<- Inf ymax<- -Inf for(J in 1:length(DataF)){ Tmp<- DataF[[J]] ymin<- min(ymin, min(Tmp)) ymax<- max(ymax,max(Tmp)) } # 11.07.21(upto) Hako<- Boxplotdata2(dataf, size[2]/size[1], ...) if(plot){ Windisp(Hako) } Tmp<- Formatting(size[1]/(XMAX-XMIN),5,5) unit<- paste(Tmp,"cm",sep="") Setunitlen(unit) Exstr<- c( "","", paste("Beginpicture(","'",unit,"')",sep=""), paste("Setpt(",as.character(ptsize),")",sep=""), "","", paste("Drwboxframe(",var,")",sep=""), paste("VtickLV(c(",as.character(ymin),",", as.character(ymax),"),0,0)",sep=""), "","","","", "Setpt(1)", "Endpicture(0)" ) Exstr<- matrix(Exstr) Xpos<- c() for(i in Looprange(1,length(Hako)-1)){ Temp <- Hako[[i]] Temp1 <- Temp[[5]] Xpos <- c(Xpos,Temp1[1,1]) } Info<- list(stats=Stats,window=matrix(c(XMIN,XMAX,YMIN,YMAX),nrow=2),xpos=Xpos) Tmp<- paste(var,"<<- ", "list(title=title,cap=cap,ylab=ylab,", "commands=Exstr,plotdata=Hako,info=Info)",sep="") eval(parse(text=Tmp)) } ########################################### Histplotdata <- function(DataV,Ratio,freq=TRUE,densplot=FALSE,...) # 10.12.07 freq { Temp <- hist(DataV,plot=FALSE,...) Breaks <- Temp$breaks Counts <- Temp$counts Density <- Temp$density Mids <- Temp$mids if (!freq){ Data<- Density } else{ Data<- Counts } Ghist <- list() for(i in Looprange(1,length(Breaks)-1)){ Tmp1 <- c(Breaks[i],Breaks[i+1]) Tmp2 <- c(0,Data[i]) G1 <- Framedata(Tmp1,Tmp2) #bar Ghist <- c(Ghist,list(G1)) } Bin <- Breaks[2]-Breaks[1] Eps <- 0.7*Bin # 0.7 times Bin Temp1 <- c(min(Breaks)-Eps,max(Breaks)+Eps) # Put Eps at both sides Temp2 <- c(0,max(Data)*1.02) Setwindow(Temp1,Temp2) Setorigin(c(Temp1[1],0)) R1<- (YMAX-YMIN)/(XMAX-XMIN) R<- Ratio/R1 Setscaling(R) VEps <- 0.05*(XMAX-XMIN)/5 Temp1<- Temp1-c(VEps,0) Temp2<- Temp2-1/R*c(VEps,0) Setwindow(Temp1,Temp2) Fpt <- c(Mids[1]-Bin,0) Lpt <- c(Mids[length(Mids)]+Bin,0) Fp <- matrix(Fpt,nrow=1) for(i in Looprange(1,length(Mids))){ Tmp <- c(Mids[i],Data[i]) Fp <- rbind(Fp,Tmp) } Fp <- rbind(Fp,Lpt) rownames(Fp)<- c(1:nrow(Fp)) if(densplot){ Temp <- density(DataV) X <- matrix(Temp$x) Y <- matrix(Temp$y) Gdens <- cbind(X,Y) } else{ Gdens <- list() } list(plotdata=list(histplot=Ghist,fpplot=list(Fp),densityplot=list(Gdens)), breaks=Breaks,counts=Counts,density=Density,mids=Mids) } Drwhistframe<-function(HistDataL) { title<- HistDataL$title xlab<- HistDataL$xlab ylab<- HistDataL$ylab if(mode(title)!="list") title<- list(title) if(mode(xlab)!="list") cap<- list(xlab) if(mode(ylab)!="list") cap<- list(ylab) if(length(title)==0) title<- list("") if(length(title)==1) title<- c(title, list("n")) if(length(title)==2) title<- c(title, list("")) if(length(xlab)==0) xlab<- list("") if(length(xlab)==1) xlab<- c(xlab, list("n")) if(length(xlab)==2) xlab<- c(xlab, list("")) if(length(xlab)==3) xlab<- c(xlab, list(8)) if(length(ylab)==0) ylab<- list("") if(length(ylab)==1) ylab<- c(ylab, list("n")) if(length(ylab)==2) ylab<- c(ylab, list("")) if(nchar(title[[1]])>0){ Fontsize(title[[2]]) Tmp1<- title[[1]] Tmp3<- title[[3]] if(nchar(Tmp3)>0){ Tmp1<- paste("{\\",Tmp3," ",Tmp1,"}",sep="") } Letter(c((XMIN+XMAX)/2,YMAX),"n2",Tmp1) Fontsize("n") } if(nchar(xlab[[1]])>0){ Fontsize(xlab[[2]]) Tmp1<- xlab[[1]] Tmp3<- xlab[[3]] if(nchar(Tmp3)>0){ Tmp1<- paste("{\\",Tmp3," ",Tmp1,"}",sep="") } Tmp4<- paste("s",as.character(xlab[[4]]),sep="") Letter(c((XMIN+XMAX)/2,YMIN),Tmp4,Tmp1) Fontsize("n") } if(nchar(ylab[[1]])>0){ Fontsize(ylab[[2]]) Tmp1<- ylab[[1]] Tmp3<- ylab[[3]] if(nchar(Tmp3)>0){ Tmp1<- paste("{\\",Tmp3," ",Tmp1,"}",sep="") } Tmp<- Setorigin() Letter(c(Tmp[1], YMAX),"n2",Tmp1) Fontsize("n") } Setax(2," ") Setax(4," ") Setax(6," ") } Drwhistplot<- function(datav,var,size,freq=TRUE, title=list(""), xlab=list(""), ylab=list(""), plot=TRUE,densplot=FALSE,fpplot=TRUE,...) #Output : title,xlab,ylab,commands,plotdata,info { H <- Histplotdata(datav, size[2]/size[1], freq=freq,densplot=densplot,...) Pd<- H$plotdata Ghist <- list(histplot=Pd$histplot,densityplot=Pd$densityplot) # 10.12.07 if(fpplot){ Ghist<- c(Ghist,list(fpplot=Pd$fpplot)) } if(plot){ Windisp(Ghist) } Tmp<- Formatting(size[1]/(XMAX-XMIN),5,5) unit<- paste(Tmp,"cm",sep="") Setunitlen(unit) Infostr<- paste(var,"$info",sep="") Brkstr<- paste(Infostr,"$breaks",sep="") Midstr<- paste(Infostr,"$mids",sep="") if (!freq){ Digits<- ",2,2" Denstr<- paste(Infostr,"$density",sep="") } else{ Digits<- ",0,0" Denstr<- paste(Infostr,"$counts",sep="") } if (fpplot) Prefp<- "" else Prefp<- "#" Exstr<- c( "","", paste("Beginpicture(","'",unit,"')",sep=""), "","", paste("Drwhistframe(",var,")",sep=""), paste("HtickLV(",Midstr,",1,1)",sep=""), paste("VtickLV(max(",Denstr,")",Digits,")",sep=""), paste("Drwline(",var,"[['plotdata']]","$histplot)",sep=""), paste(Prefp,"Dashline(",var,"[['plotdata']]","$fpplot)",sep=""), paste("#Drwline(",var,"[['plotdata']]","$densityplot,2)",sep=""), "","","","", "Endpicture(1)" ) Exstr<- matrix(Exstr) Info<- list(breaks=H$breaks,counts=H$counts,density=H$density,mids=H$mids, window=matrix(c(XMIN,XMAX,YMIN,YMAX),nrow=2)) Tmp<- paste(var,"<<- ", "list(title=title,xlab=xlab,ylab=ylab,", "commands=Exstr,plotdata=Ghist,info=Info)",sep="") eval(parse(text=Tmp)) } ########################## #17.09.30 Bezierpt<- function(t,Ptlist,Ctrlist){ if(length(Ptlist)==6){ P0=Ptlist[1:3] P3=Ptlist[4:6] P1=Ctrlist[1:3] if(length(Ctrlist)==3){ P2=P3 flg3=0 }else{ P2=Ctrlist[4:6] flg3=1 } }else{ P0=Ptlist[1:2] P3=Ptlist[3:4] P1=Ctrlist[1:2] if(length(Ctrlist)==2){ P2=P3 flg3=0 }else{ P2=Ctrlist[3:4] flg3=1 } } P4=(1-t)*P0+t*P1 P5=(1-t)*P1+t*P2 P6=(1-t)*P2+t*P3 P7=(1-t)*P4+t*P5 P8=(1-t)*P5+t*P6 P9=(1-t)*P7+t*P8 if(flg3==0){ Out=P7 }else{ Out=P9 } return(Out) } Bezier<- function(...){ varargin<- list(...) Nargs=length(varargin) Ptlist=varargin[[1]] Ctrlist=varargin[[2]] Num=10 for(J in Looprange(3,Nargs)){ Tmp=varargin[[J]] K=strsplit(Tmp,'=',fixe=TRUE) K=K[[1]] Tmp1=substring(K[1],1,1) Lhs=toupper(Tmp1) if(Lhs=="N"){ Num=eval(parse(text=K[2])) } } if(length(Num)==1){ Num=rep(Num,length(Ctrlist)) #17.10.08 } Out=c() for(ii in Looprange(1,length(Ctrlist))){ Tmp1=c(Ptlist[[ii]],Ptlist[[ii+1]]) Tmp2=Ctrlist[[ii]] if(ii==1){ St=0 }else{ St=1 } for(J in Looprange(St,Num[ii])){ Tmp=Bezierpt(J/Num[ii],Tmp1,Tmp2) Out=Appendrow(Out,Tmp) } } return(Out) } ####################### # 17.10.02 Connectseg<- function(...){ varargin=list(...) Nargs=length(varargin) Pdata=varargin[[1]] Eps=10^(-5) if(Nargs>=2){ Eps=varargin[[2]] } if(is.matrix(Pdata)){ Din=Dataindex(Pdata) tmp1=list() for(J in 1:nrow(Din)){ tmp=Pdata[Din[J,1]:Din[J,2],] tmp1=c(tmp1,list(tmp)) } Pdata=tmp1 } PlotL=Pdata[1] VI=2:length(Pdata) while(length(VI)>0){ Qd=PlotL[[length(PlotL)]] Ah=Qd[1,]; Ao=Qd[nrow(Qd),] Flg=0 for(J in 1:length(VI)){ Tmp1=Pdata[[VI[J]]] P=Tmp1[1,]; Q=Tmp1[nrow(Tmp1),] if(Norm(P-Ao)=4){ Tmp=Op(4,MS) if(nrow(Tmp)>1){ Mdv=Tmp[1,1] Ndv=Tmp[1,2] }else{ Mdv=Tmp if(Nargs==4){ Ndv=Mdv }else{ Tmp1=Op(5,MS) if((is.numeric(Tmp1))&&(length(Tmp1)==1)){ Ndv=Tmp1 }else{ Ndv=Mdv } } } } X1=Xrange[1]; X2=Xrange[2] Y1=Yrange[1]; Y2=Yrange[2] Dx=(X2-X1)/Mdv Dy=(Y2-Y1)/Ndv Xval=c() Tmp=X1 while(TmpEps){ if(VL[K+1]< -Eps){ Tmp=1/(VL[K]-VL[K+1])*(-VL[K+1]*PL[K,]+VL[K]*PL[K+1,]) QL=Appendrow(QL,Tmp) } }else{ if(VL[K+1]>Eps){ Tmp=1/(-VL[K]+VL[K+1])*(VL[K+1]*PL[K,]-VL[K]*PL[K+1,]) QL=Appendrow(QL,Tmp) } } } if(length(QL)==4){ Out=Appendrow(Out,c(Inf,Inf)) Out=Appendrow(Out,QL) } } } Out=Out[2:nrow(Out),] if(length(Out)>0){ Out=Connectseg(Out) }else{ Out=c() } return(Out) } ######################### # 17.10.06 Deqdata=function(deq,rng,initt,initf,Num){ Eps=10^(-3) inf=10^3 tmp=strsplit(deq,"=")[[1]] tmp1=gsub("`","",tmp[1],fixed=TRUE) tmp1=substring(tmp1,3,nchar(tmp1)-1) Xname=strsplit(tmp1,",")[[1]] func=tmp[2] for(J in 1:(length(Xname))){ tmp1=paste("X[",as.character(J),"]",sep="") func=gsub(Xname[J],tmp1,func,fixed=TRUE) } tmp=strsplit(rng,"=")[[1]] tname=tmp[1] tmp=eval(parse(text=tmp[2])) t1=tmp[1] t2=tmp[2] tmp=paste("function(",tname,",X){",func,"}",sep="") funP=eval(parse(text=tmp)) tmp=paste("function(",tname,",X){-",func,"}",sep="") funN=eval(parse(text=tmp)) dt=(t2-t1)/Num tt=initt X0=initf pdL=c(tt,X0) for(J in 1:(floor((t2-initt)/dt))){ kl1=dt*funP(tt,X0) kl2=dt*funP(tt+dt/2,X0+kl1/2) kl3=dt*funP(tt+dt/2,X0+kl2/2) kl4=dt*funP(tt+dt,X0+kl3) X0=X0+(kl1+2*kl2+2*kl3+kl4)/6 tt=initt+J*dt tmp=c(tt,X0) if(Norm(tmp)>inf){break} pdL=Appendrow(pdL,tmp) } tt=initt X0=initf for(J in 1:(floor((initt-t1)/dt))){ kl1=dt*funN(tt,X0) kl2=dt*funN(tt+dt/2,X0+kl1/2) kl3=dt*funN(tt+dt/2,X0+kl2/2) kl4=dt*funN(tt+dt,X0+kl3) X0=X0+(kl1+2*kl2+2*kl3+kl4)/6 tt=initt-J*dt tmp=c(tt,X0) if(Norm(tmp)>inf){break} pdL=Appendrow(tmp,pdL) } pdL } Deqplot=function(...){ varargin=list(...) deq=varargin[[1]] rng=varargin[[2]] initt=varargin[[3]] initf=varargin[[4]] Num=50 Sel=c(1,2) for(J in Looprange(5,length(varargin))){ tmp1=varargin[[J]] if(is.character(tmp1)){ tmp=strsplit(tmp1,"=")[[1]] Num=eval(parse(text=tmp[2])) }else{ SeL=tmp1 } } pdL=Deqdata(deq,rng,initt,initf,Num) pdL=pdL[,SeL] }