# 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 (D21)
{
Vname<- K[1]
Tmp1<- K[2]
Rng<- eval(parse(text=Tmp1))
}
else
{
Vname<- Rgstr
Rng<- c(0,2*pi)
}
T1<- Rng[1]; T2<- Rng[2]
Dt<- (T2-T1)/N #17.09.22
if (Fnflg==0)
{
Str<- gsub(Vname,"t",Fnstr)
}
P<-c()
if (length(E)>0)
{
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(Pars1){
Vname<- K[1]
Tmp1<- K[2]
Rng<- eval(parse(text=Tmp1))
}
else{
Vname<- Rgstr
Rng<- c(XMIN,XMAX)
}
N<- 50 # Numpoints
E<-c() # Exclusions
Exfun<- "" # Exclusion function
D<- Inf # Discont
for (I in Looprange(Is,length(varargin))){
Tmp<- varargin[[I]]
Lhs<- substring(Tmp,1,1)
Tmp<- strsplit(Tmp,"=")
K<- Tmp[[1]]
Tmp1<- K[2]
Tmp2<- grep(Vname,Tmp1,fixed=TRUE) ## 10.12.04
if (length(Tmp2)==0){
Str<-paste(Lhs,"=",Tmp1,sep="")
eval(parse(text=Str))
}
else{
Exfun<-Tmp1
}
}
X1<- Rng[1]; X2<- Rng[2]
dx<- (X2-X1)/N # 17.09.22
if (Fnflg==0){
Str<- gsub(Vname,"x",Fnstr,fixed=TRUE)
}
Exfun<- gsub(Vname,"x",Exfun,fixed=TRUE)
P<-c()
if (length(E)>0){
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))
Px<- c(Tmp[1],0,0)
Qx<- c(Tmp[2],0,0)
StrV<-strsplit(Yrange,"=",fixed=TRUE)
StrV<- StrV[[1]]
if(length(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) 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]
}