绘制向量之间的角度 [英] Plot angle between vectors
本文介绍了绘制向量之间的角度的处理方法，对大家解决问题具有一定的参考价值，需要的朋友们下面随着小编来一起学习吧！
问题描述
我已经搜索了很长一段时间来寻找绘制两个箭头/线段之间角度的函数.例如:
(来源:
## 辅助变量和函数tau <- pi*2;圆 <- 函数(x,y,r,fg,bg,lty,lwd,n.angle=2000,n.bg=2000,...) {梳<- cbind(x,y,r);角度 <- seq(0,tau,len=n.angle);if (!missing(fg) && !is.null(fg)) fg <- rep(fg,len=nrow(comb));if (!missing(bg) && !is.null(bg)) bg <- rep(bg,len=nrow(comb));if (!missing(lty) && !is.null(lty)) lty <- rep(lty,len=nrow(comb));if (!missing(lwd) && !is.null(lwd)) lwd <- rep(lwd,len=nrow(comb));for (i in seq_len(nrow(comb))) {xc <- comb[i,'x'];yc <- 组合[i,'y'];rc <- 组合[i,'r'];xs <- xc+rc*cos(angles);ys <- yc+rc*sin(angles);## 可选的背景如果 (!missing(bg) && !is.null(bg)) {bgc <- bg[i];rs.bg <-seq(r,-r,len=n.bg);xs.bg <- sqrt(rc^2 - rs.bg^2);ys.bg <- yc+rs.bg;段(xc-xs.bg,ys.bg,xc+xs.bg,col=bgc,lty=1,lwd=1);};## 万一args <- 列表(xs，ys)；if (!missing(fg)) if (is.null(fg)) args['col'] <- list(NULL) else args$col <- fg[i];if (!missing(lty)) if (is.null(lty)) args['lty'] <- list(NULL) else args$lty <- lty[i];if (!missing(lwd)) if (is.null(lwd)) args['lwd'] <- list(NULL) else args$lwd <- lwd[i];do.call(lines,c(args,...));};## 结束于};## 结束圆()径向 <- 函数(x，y，a，r，...){梳<- cbind(x,y,a,r);段(梳[,'x'],梳[,'y'],梳[,'x']+梳[,'r']*cos(梳[,'a']),梳[,'y']+comb[,'r']*sin(comb[,'a']),...);};## 结束径向()circle.segments <- function(x,y,r,a1,a2,fg,bg,lty,lwd,n.angle=2000,fg.chord,fg.arc,...) {梳<- cbind(x,y,r,a1,a2);if (!missing(fg) && !is.null(fg)) fg <- rep(fg,len=nrow(comb));if (!missing(fg.chord) && !is.null(fg.chord)) fg.chord <- rep(fg.chord,len=nrow(comb)) else if (missing(fg.chord)) && !missing(fg)) fg.chord <- fg;if (!missing(fg.arc) && !is.null(fg.arc)) fg.arc <- rep(fg.arc,len=nrow(comb)) else if (missing(fg.arc)) && !missing(fg)) fg.arc <- fg;if (!missing(bg) && !is.null(bg)) bg <- rep(bg,len=nrow(comb));if (!missing(lty) && !is.null(lty)) lty <- rep(lty,len=nrow(comb));if (!missing(lwd) && !is.null(lwd)) lwd <- rep(lwd,len=nrow(comb));for (i in seq_len(nrow(comb))) {xc <- comb[i,'x'];yc <- 组合[i,'y'];rc <- 组合[i,'r'];a1c <- comb[i,'a1'];a2c <- comb[i,'a2'];角度 <- seq(a1c,a2c,len=n.angle);tan.angles <- tan(angles);xs <- xc+rc*cos(angles);ys <- yc+rc*sin(angles);x1 <- xs[1];y1 <- ys[1];x2 <- xs[长度(xs)];y2 <- ys[长度(ys)];## 可选的背景如果 (!missing(bg) && !is.null(bg)) {bgc <- bg[i];xs.chord <- seq(x1,x2,len=n.angle);ys.chord <- seq(y1,y2,len=n.angle);段(xs.chord,ys.chord,xs,ys,col=bg,lty=1,lwd=1);};## 万一##和弦片段args <- 列表(x1,y1,x2,y2);if (!missing(fg.chord)) if (is.null(fg.chord)) args['col'] <- list(NULL) else args$col <- fg.chord[i];if (!missing(lty)) if (is.null(lty)) args['lty'] <- list(NULL) else args$lty <- lty[i];if (!missing(lwd)) if (is.null(lwd)) args['lwd'] <- list(NULL) else args$lwd <- lwd[i];do.call(segments,c(args,...));##圆弧段args <- 列表(xs，ys)；if (!missing(fg.arc)) if (is.null(fg.arc)) args['col'] <- list(NULL) else args$col <- fg.arc[i];if (!missing(lty)) if (is.null(lty)) args['lty'] <- list(NULL) else args$lty <- lty[i];if (!missing(lwd)) if (is.null(lwd)) args['lwd'] <- list(NULL) else args$lwd <- lwd[i];do.call(lines,c(args,...));};## 结束于};## 结束 circle.segments()circle.sectors <- function(x,y,r,a1,a2,fg,bg,lty,lwd,n.angle=2000,fg.a1,fg.a2,fg.arc,...) {梳<- cbind(x,y,r,a1,a2);if (!missing(fg) && !is.null(fg)) fg <- rep(fg,len=nrow(comb));if (!missing(fg.a1) && !is.null(fg.a1)) fg.a1 <- rep(fg.a1,len=nrow(comb)) else if (missing(fg.a1)) && !missing(fg)) fg.a1 <- fg;if (!missing(fg.a2) && !is.null(fg.a2)) fg.a2 <- rep(fg.a2,len=nrow(comb)) else if (missing(fg.a2)) && !missing(fg)) fg.a2 <- fg;if (!missing(fg.arc) && !is.null(fg.arc)) fg.arc <- rep(fg.arc,len=nrow(comb)) else if (missing(fg.arc)) && !missing(fg)) fg.arc <- fg;if (!missing(bg) && !is.null(bg)) bg <- rep(bg,len=nrow(comb));if (!missing(lty) && !is.null(lty)) lty <- rep(lty,len=nrow(comb));if (!missing(lwd) && !is.null(lwd)) lwd <- rep(lwd,len=nrow(comb));for (i in seq_len(nrow(comb))) {xc <- comb[i,'x'];yc <- 组合[i,'y'];rc <- 组合[i,'r'];a1c <- comb[i,'a1'];a2c <- comb[i,'a2'];角度 <- seq(a1c,a2c,len=n.angle);xs <- xc+rc*cos(angles);ys <- yc+rc*sin(angles);## 可选的背景如果 (!missing(bg) && !is.null(bg)) {bgc <- bg[i];段(xc，yc，xs，ys，col=bgc，lty=1，lwd=1)；};## 万一## a1 段args <- list(xc,yc,xs[1],ys[1]);if (!missing(fg.a1)) if (is.null(fg.a1)) args['col'] <- list(NULL) else args$col <- fg.a1[i];if (!missing(lty)) if (is.null(lty)) args['lty'] <- list(NULL) else args$lty <- lty[i];if (!missing(lwd)) if (is.null(lwd)) args['lwd'] <- list(NULL) else args$lwd <- lwd[i];do.call(segments,c(args,...));## a2 段args <- list(xc,yc,xs[length(xs)],ys[length(ys)]);if (!missing(fg.a2)) if (is.null(fg.a2)) args['col'] <- list(NULL) else args$col <- fg.a2[i];if (!missing(lty)) if (is.null(lty)) args['lty'] <- list(NULL) else args$lty <- lty[i];if (!missing(lwd)) if (is.null(lwd)) args['lwd'] <- list(NULL) else args$lwd <- lwd[i];do.call(segments,c(args,...));##圆弧段args <- 列表(xs，ys)；if (!missing(fg.arc)) if (is.null(fg.arc)) args['col'] <- list(NULL) else args$col <- fg.arc[i];if (!missing(lty)) if (is.null(lty)) args['lty'] <- list(NULL) else args$lty <- lty[i];if (!missing(lwd)) if (is.null(lwd)) args['lwd'] <- list(NULL) else args$lwd <- lwd[i];do.call(lines,c(args,...));};## 结束于};## 结束 circle.sectors()intersect.lines <- function(a1x,a1y,a2x,a2y,b1x,b1y,b2x,b2y) {梳 <- cbind(a1x,b1x,a2x,b2x,a1y,b1y,a2y,b2y);梳子 <- 数组(梳子，c(nrow(梳子)，2,2,2)，dimnames=list(NULL，c('a'，'b')，NULL，c('x'，'y'))));any.points <- any(comb[,'a',1,'x'] == comb[,'a',2,'x'] & comb[,'a',1,'y'] == 梳[,'a',2,'y']) ||any(comb[,'b',1,'x'] == comb[,'b',2,'x'] & comb[,'b',1,'y'] == comb[,'b',2,'y']);any.points[is.na(any.points)] <- F;if (any.points) stop('重合 1 和 2 点.');ma <- (comb[,'a',2,'y'] - 梳[,'a',1,'y'])/(comb[,'a',2,'x'] - 梳[,'a',1,'x']);mb <- (comb[,'b',2,'y'] - 梳[,'b',1,'y'])/(comb[,'b',2,'x'] - 梳[,'b',1,'x']);b.a <- comb[,'a',1,'y'] - m.a*comb[,'a',1,'x'];b.b <- comb[,'b',1,'y'] - m.b*comb[,'b',1,'x'];a.inf <- is.infinite(m.a);b.inf <- is.infinite(m.b);并行 <- ifelse(a.inf,ifelse(b.inf,T,F),ifelse(b.inf,F,m.a == m.b));x1equal <- comb[,'a',1,'x'] == comb[,'b',1,'x'];重合 <- ifelse(a.inf,ifelse(b.inf,x1equal,F),ifelse(b.inf,F,parallel & b.a == b.b));xi <- ifelse(concident,Inf,ifelse(parallel,NaN,ifelse(a.inf,comb[,'a',1,'x'],ifelse(b.inf,comb[,'b',1),'x'],(bb - ba)/(ma - mb)))));yi <- ifelse(concident,Inf,ifelse(parallel,NaN,ifelse(a.inf,mb*comb[,'a',1,'x'] + bb,ifelse(b.inf,ma*comb[,'b',1,'x'] + ba,ma*xi + ba))));xi[is.na(yi) &!is.nan(yi)] <- NA;yi[is.na(xi) &!is.nan(xi)] <- NA;cbind(x=xi,y=yi);};箭头.填充 <- 功能(x1,y1,x2=x1,y2=y1,a=tau/32,al=a,ar=a,len=sqrt(diff(par('usr')[3:4])^2+diff(par('usr')[1:2])^2)/20,lenl=len,lenr=len,fg,bg,bgl,bgr,lty,lwd,fg.mainline,lty.mainline,lwd.mainline,fg.tipline,lty.tipline,lwd.tipline,fg.lwing,lty.lwing,lwd.lwing,fg.rwing,lty.rwing,lwd.rwing,fg.lcross,lty.lcross,lwd.lcross,fg.rcross,lty.rcross,lwd.rcross,...){梳 <- cbind(x1,y1,x2,y2,al,ar,lenl,lenr);if (!missing(fg) && !is.null(fg)) fg <- rep(fg,len=nrow(comb));if (!missing(lty) && !is.null(lty)) lty <- rep(lty,len=nrow(comb));if (!missing(lwd) && !is.null(lwd)) lwd <- rep(lwd,len=nrow(comb));if (!missing(fg.mainline) && !is.null(fg.mainline)) fg.mainline <- rep(fg.mainline,len=nrow(comb)) else if (missing(fg.mainline)) && !missing(fg)) fg.mainline <- fg;if (!missing(fg.tipline) && !is.null(fg.tipline)) fg.tipline <- rep(fg.tipline,len=nrow(comb)) else if (missing(fg.tipline)) && !missing(fg)) fg.tipline <- fg;if (!missing(fg.lwing) && !is.null(fg.lwing)) fg.lwing <- rep(fg.lwing,len=nrow(comb)) else if (missing(fg.lwing)) && !missing(fg)) fg.lwing <- fg;if (!missing(fg.rwing) && !is.null(fg.rwing)) fg.rwing <- rep(fg.rwing,len=nrow(comb)) else if (missing(fg.rwing)) && !missing(fg)) fg.rwing <- fg;if (!missing(fg.lcross) && !is.null(fg.lcross)) fg.lcross <- rep(fg.lcross,len=nrow(comb)) else if (missing(fg.lcross)) && !missing(fg)) fg.lcross <- fg;if (!missing(fg.rcross) && !is.null(fg.rcross)) fg.rcross <- rep(fg.rcross,len=nrow(comb)) else if (missing(fg.rcross)) && !missing(fg)) fg.rcross <- fg;if (!missing(lty.mainline) && !is.null(lty.mainline)) lty.mainline <- rep(lty.mainline,len=nrow(comb)) else if (missing(lty.mainline)) && !missing(lty)) lty.mainline <- lty;if (!missing(lty.tipline) && !is.null(lty.tipline)) lty.tipline <- rep(lty.tipline,len=nrow(comb)) else if (missing(lty.tipline)) && !missing(lty)) lty.tipline <- lty;if (!missing(lty.lwing) && !is.null(lty.lwing)) lty.lwing <- rep(lty.lwing,len=nrow(comb)) else if (missing(lty.lwing)) && !missing(lty)) lty.lwing <- lty;if (!missing(lty.rwing) && !is.null(lty.rwing)) lty.rwing <- rep(lty.rwing,len=nrow(comb)) else if (missing(lty.rwing)) && !missing(lty)) lty.rwing <- lty;if (!missing(lty.lcross) && !is.null(lty.lcross)) lty.lcross <- rep(lty.lcross,len=nrow(comb)) else if (missing(lty.lcross)) && !missing(lty)) lty.lcross <- lty;if (!missing(lty.rcross) && !is.null(lty.rcross)) lty.rcross <- rep(lty.rcross,len=nrow(comb)) else if (missing(lty.rcross)) && !missing(lty)) lty.rcross <- lty;if (!missing(lwd.mainline) && !is.null(lwd.mainline)) lwd.mainline <- rep(lwd.mainline,len=nrow(comb)) else if (missing(lwd.mainline)) && !missing(lwd)) lwd.mainline <- lwd;if (!missing(lwd.tipline) && !is.null(lwd.tipline)) lwd.tipline <- rep(lwd.tipline,len=nrow(comb)) else if (missing(lwd.tipline)) && !missing(lwd)) lwd.tipline <- lwd;if (!missing(lwd.lwing) && !is.null(lwd.lwing)) lwd.lwing <- rep(lwd.lwing,len=nrow(comb)) else if (missing(lwd.lwing)) && !missing(lwd)) lwd.lwing <- lwd;if (!missing(lwd.rwing) && !is.null(lwd.rwing)) lwd.rwing <- rep(lwd.rwing,len=nrow(comb)) else if (missing(lwd.rwing)) && !missing(lwd)) lwd.rwing <- lwd;if (!missing(lwd.lcross) && !is.null(lwd.lcross)) lwd.lcross <- rep(lwd.lcross,len=nrow(comb)) else if (missing(lwd.lcross)) && !missing(lwd)) lwd.lcross <- lwd;if (!missing(lwd.rcross) && !is.null(lwd.rcross)) lwd.rcross <- rep(lwd.rcross,len=nrow(comb)) else if (missing(lwd.rcross)) && !missing(lwd)) lwd.rcross <- lwd;if (!missing(bg) && !is.null(bg)) bg <- rep(bg,len=nrow(comb));if (!missing(bgl) && !is.null(bgl)) bgl <- rep(bgl,len=nrow(comb)) else if (missing(bgl) && !missing(bg)) bgl <- bg;if (!missing(bgr) && !is.null(bgr)) bgr <- rep(bgr,len=nrow(comb)) else if (missing(bgr) && !missing(bg)) bgr <- bg;for (i in seq_len(nrow(comb))) {x1c <- comb[i,'x1'];y1c <- 组合[i,'y1'];x2c <- comb[i,'x2'];y2c <- 组合[i,'y2'];alc <- comb[i,'al'];arc <- comb[i,'ar'];if (alc <= 0 || alc >= tau/2) stop(paste0('arrow ',i,' 左角无效',alc,'.'));if (arc <= 0 || arc >= tau/2) stop(paste0('arrow ',i,' 的直角无效',alc,'.'));lenlc <- 组合[i,'lenl'];lenrc <- comb[i,'lenr'];β <- atan2(y2c-y1c,x2c-x1c);xl <- x2c - lenlc*cos(beta - alc);yl＜-y2c-lenlc*sin(beta-alc)；xr <- x2c - lenrc*sin(tau/4 - beta - arc);yr <- y2c - lenrc*cos(tau/4 - beta - arc);with(as.data.frame(intersect.lines(x1c,y1c,x2c,y2c,xl,yl,xr,yr)),{ e <- parent.env(environment()); e$xi <-x; e$yi <- y; });##主线args <- list(x1c,y1c,xi,yi);if (!missing(fg.mainline)) if (is.null(fg.mainline)) args['col'] <- list(NULL) else args$col <- fg.mainline[i];if (!missing(lty.mainline)) if (is.null(lty.mainline)) args['lty'] <- list(NULL) else args$lty <- lty.mainline[i];if (!missing(lwd.mainline)) if (is.null(lwd.mainline)) args['lwd'] <- list(NULL) else args$lwd <- lwd.mainline[i];do.call(segments,c(args,...));## bg 左如果 (!missing(bgl) && !is.null(bgl)) {bglc <- bgl[i];多边形(c(x2c,xl,xi),c(y2c,yl,yi),border=NA,col=bglc);};## 万一## 正确的 bg如果 (!missing(bgr) && !is.null(bgr)) {bgrc <- bgr[i];多边形(c(x2c,xr,xi),c(y2c,yr,yi),border=NA,col=bgrc);};## 万一## tipline -- 只有在至少给出了一个tipline arg时才绘制if (!missing(fg.tipline) || !missing(lty.tipline) || !missing(lwd.tipline)) {args <- 列表(xi,yi,x2c,y2c);if (!missing(fg.tipline)) if (is.null(fg.tipline)) args['col'] <- list(NULL) else args$col <- fg.tipline[i];if (!missing(lty.tipline)) if (is.null(lty.tipline)) args['lty'] <- list(NULL) else args$lty <- lty.tipline[i];if (!missing(lwd.tipline)) if (is.null(lwd.tipline)) args['lwd'] <- list(NULL) else args$lwd <- lwd.tipline[i];do.call(segments,c(args,...));};## 万一## lwingargs <- 列表(x2c,y2c,xl,yl);if (!missing(fg.lwing)) if (is.null(fg.lwing)) args['col'] <- list(NULL) else args$col <- fg.lwing[i];if (!missing(lty.lwing)) if (is.null(lty.lwing)) args['lty'] <- list(NULL) else args$lty <- lty.lwing[i];if (!missing(lwd.lwing)) if (is.null(lwd.lwing)) args['lwd'] <- list(NULL) else args$lwd <- lwd.lwing[i];do.call(segments,c(args,...));## 翼翼args <- 列表(x2c,y2c,xr,yr);if (!missing(fg.rwing)) if (is.null(fg.rwing)) args['col'] <- list(NULL) else args$col <- fg.rwing[i];if (!missing(lty.rwing)) if (is.null(lty.rwing)) args['lty'] <- list(NULL) else args$lty <- lty.rwing[i];if (!missing(lwd.rwing)) if (is.null(lwd.rwing)) args['lwd'] <- list(NULL) else args$lwd <- lwd.rwing[i];do.call(segments,c(args,...));## lcrossargs <- list(xl,yl,xi,yi);if (!missing(fg.lcross)) if (is.null(fg.lcross)) args['col'] <- list(NULL) else args$col <- fg.lcross[i];if (!missing(lty.lcross)) if (is.null(lty.lcross)) args['lty'] <- list(NULL) else args$lty <- lty.lcross[i];if (!missing(lwd.lcross)) if (is.null(lwd.lcross)) args['lwd'] <- list(NULL) else args$lwd <- lwd.lcross[i];do.call(segments,c(args,...));## rcrossargs <- list(xr,yr,xi,yi);if (!missing(fg.rcross)) if (is.null(fg.rcross)) args['col'] <- list(NULL) else args$col <- fg.rcross[i];if (!missing(lty.rcross)) if (is.null(lty.rcross)) args['lty'] <- list(NULL) else args$lty <- lty.rcross[i];if (!missing(lwd.rcross)) if (is.null(lwd.rcross)) args['lwd'] <- list(NULL) else args$lwd <- lwd.rcross[i];do.call(segments,c(args,...));};## 结束于};## 结束 arrows.filled()## 基本情节大纲par(xaxs='i',yaxs='i');xlim <- c(0,8);ylim <- c(0,6);额外 <- 0.5;plot(NA,xlim=xlim+extra*c(-1,1),ylim=ylim+extra*c(-1,1),axes=F,ann=F);##自定义轴xtick <- 0:8;ytick <- 0:6;tick.len <- 0.06;tick.zeroadd <- 0.1;段(xtick,0,xtick,-tick.len,lwd=2);段(0，ytick，-tick.len，ytick，lwd = 2)；abline(h=0,lwd=2);abline(v=0,lwd=2);文本(xtick[-1],-tick.len/2,xtick[-1],pos=1,font=2);文本(xtick[1]+tick.zeroadd,-tick.len/2,xtick[1],pos=1,font=2);文本(-tick.len/2,ytick[-1],ytick[-1],pos=2,font=2);文本(-tick.len/2,ytick[1]+tick.zeroadd,ytick[1],pos=2,font=2);##定义要点V1＜-c(2,5)；V2＜-c(7,1)；## 带标签的圆形扇区V1.angle <- atan2(V1[2],V1[1]);V2.angle <- atan2(V2[2],V2[1]);扇区半径＜- 2；circle.sectors(0,0,sector.radius,V1.angle,V2.angle,'#277A27','#E5EFE5',lwd=2);label.radius <- 1.1;label.angle <- mean(c(V1.angle,V2.angle));text(label.radius*cos(label.angle),label.radius*sin(label.angle),'α',family='serif',cex=1.3,col='#277A27');##箭头arrows.filled(0,0,V1[1],V1[2],a=tau*12/360,len=0.25,lwd=2,bg='black');arrows.fill(0,0,V2[1],V2[2],a=tau*12/360,len=0.25,lwd=2,bg='black');##点圆circles(c(V1[1],V2[1]),c(V1[2],V2[2]),0.08,'black','blue');##点标签text(V1[1]+0.03,V1[2]+0.2,sprintf('V1 = (%d,%d)',V1[1],V1[2]),pos=4,col='blue',font=2,family='sans');text(V2[1]+0.05,V2[2]-0.2,sprintf('V2 = (%d,%d)',V2[1],V2[2]),pos=4,col='blue',font=2,family='sans');I am searching for quite a while already now for a function that plots the angle between two arrows / line segments. e.g.:
(source: matrix44.net)
Can this be done easily or do I have to find the function of a segment of a radius? I am surprised that I didn't find anything yet, since R usually has a package for everything.
解决方案
## helper variables and functions
tau <- pi*2;
circles <- function(x,y,r,fg,bg,lty,lwd,n.angle=2000,n.bg=2000,...) {
comb <- cbind(x,y,r);
angles <- seq(0,tau,len=n.angle);
if (!missing(fg) && !is.null(fg)) fg <- rep(fg,len=nrow(comb));
if (!missing(bg) && !is.null(bg)) bg <- rep(bg,len=nrow(comb));
if (!missing(lty) && !is.null(lty)) lty <- rep(lty,len=nrow(comb));
if (!missing(lwd) && !is.null(lwd)) lwd <- rep(lwd,len=nrow(comb));
for (i in seq_len(nrow(comb))) {
xc <- comb[i,'x'];
yc <- comb[i,'y'];
rc <- comb[i,'r'];
xs <- xc+rc*cos(angles);
ys <- yc+rc*sin(angles);
## optional bg
if (!missing(bg) && !is.null(bg)) {
bgc <- bg[i];
rs.bg <- seq(r,-r,len=n.bg);
xs.bg <- sqrt(rc^2 - rs.bg^2);
ys.bg <- yc+rs.bg;
segments(xc-xs.bg,ys.bg,xc+xs.bg,col=bgc,lty=1,lwd=1);
}; ## end if
args <- list(xs,ys);
if (!missing(fg)) if (is.null(fg)) args['col'] <- list(NULL) else args$col <- fg[i];
if (!missing(lty)) if (is.null(lty)) args['lty'] <- list(NULL) else args$lty <- lty[i];
if (!missing(lwd)) if (is.null(lwd)) args['lwd'] <- list(NULL) else args$lwd <- lwd[i];
do.call(lines,c(args,...));
}; ## end for
}; ## end circles()
radials <- function(x,y,a,r,...) {
comb <- cbind(x,y,a,r);
segments(comb[,'x'],comb[,'y'],comb[,'x']+comb[,'r']*cos(comb[,'a']),comb[,'y']+comb[,'r']*sin(comb[,'a']),...);
}; ## end radials()
circle.segments <- function(x,y,r,a1,a2,fg,bg,lty,lwd,n.angle=2000,fg.chord,fg.arc,...) {
comb <- cbind(x,y,r,a1,a2);
if (!missing(fg) && !is.null(fg)) fg <- rep(fg,len=nrow(comb));
if (!missing(fg.chord) && !is.null(fg.chord)) fg.chord <- rep(fg.chord,len=nrow(comb)) else if (missing(fg.chord) && !missing(fg)) fg.chord <- fg;
if (!missing(fg.arc) && !is.null(fg.arc)) fg.arc <- rep(fg.arc,len=nrow(comb)) else if (missing(fg.arc) && !missing(fg)) fg.arc <- fg;
if (!missing(bg) && !is.null(bg)) bg <- rep(bg,len=nrow(comb));
if (!missing(lty) && !is.null(lty)) lty <- rep(lty,len=nrow(comb));
if (!missing(lwd) && !is.null(lwd)) lwd <- rep(lwd,len=nrow(comb));
for (i in seq_len(nrow(comb))) {
xc <- comb[i,'x'];
yc <- comb[i,'y'];
rc <- comb[i,'r'];
a1c <- comb[i,'a1'];
a2c <- comb[i,'a2'];
angles <- seq(a1c,a2c,len=n.angle);
tan.angles <- tan(angles);
xs <- xc+rc*cos(angles);
ys <- yc+rc*sin(angles);
x1 <- xs[1];
y1 <- ys[1];
x2 <- xs[length(xs)];
y2 <- ys[length(ys)];
## optional bg
if (!missing(bg) && !is.null(bg)) {
bgc <- bg[i];
xs.chord <- seq(x1,x2,len=n.angle);
ys.chord <- seq(y1,y2,len=n.angle);
segments(xs.chord,ys.chord,xs,ys,col=bg,lty=1,lwd=1);
}; ## end if
## chord segment
args <- list(x1,y1,x2,y2);
if (!missing(fg.chord)) if (is.null(fg.chord)) args['col'] <- list(NULL) else args$col <- fg.chord[i];
if (!missing(lty)) if (is.null(lty)) args['lty'] <- list(NULL) else args$lty <- lty[i];
if (!missing(lwd)) if (is.null(lwd)) args['lwd'] <- list(NULL) else args$lwd <- lwd[i];
do.call(segments,c(args,...));
## arc segment
args <- list(xs,ys);
if (!missing(fg.arc)) if (is.null(fg.arc)) args['col'] <- list(NULL) else args$col <- fg.arc[i];
if (!missing(lty)) if (is.null(lty)) args['lty'] <- list(NULL) else args$lty <- lty[i];
if (!missing(lwd)) if (is.null(lwd)) args['lwd'] <- list(NULL) else args$lwd <- lwd[i];
do.call(lines,c(args,...));
}; ## end for
}; ## end circle.segments()
circle.sectors <- function(x,y,r,a1,a2,fg,bg,lty,lwd,n.angle=2000,fg.a1,fg.a2,fg.arc,...) {
comb <- cbind(x,y,r,a1,a2);
if (!missing(fg) && !is.null(fg)) fg <- rep(fg,len=nrow(comb));
if (!missing(fg.a1) && !is.null(fg.a1)) fg.a1 <- rep(fg.a1,len=nrow(comb)) else if (missing(fg.a1) && !missing(fg)) fg.a1 <- fg;
if (!missing(fg.a2) && !is.null(fg.a2)) fg.a2 <- rep(fg.a2,len=nrow(comb)) else if (missing(fg.a2) && !missing(fg)) fg.a2 <- fg;
if (!missing(fg.arc) && !is.null(fg.arc)) fg.arc <- rep(fg.arc,len=nrow(comb)) else if (missing(fg.arc) && !missing(fg)) fg.arc <- fg;
if (!missing(bg) && !is.null(bg)) bg <- rep(bg,len=nrow(comb));
if (!missing(lty) && !is.null(lty)) lty <- rep(lty,len=nrow(comb));
if (!missing(lwd) && !is.null(lwd)) lwd <- rep(lwd,len=nrow(comb));
for (i in seq_len(nrow(comb))) {
xc <- comb[i,'x'];
yc <- comb[i,'y'];
rc <- comb[i,'r'];
a1c <- comb[i,'a1'];
a2c <- comb[i,'a2'];
angles <- seq(a1c,a2c,len=n.angle);
xs <- xc+rc*cos(angles);
ys <- yc+rc*sin(angles);
## optional bg
if (!missing(bg) && !is.null(bg)) {
bgc <- bg[i];
segments(xc,yc,xs,ys,col=bgc,lty=1,lwd=1);
}; ## end if
## a1 segment
args <- list(xc,yc,xs[1],ys[1]);
if (!missing(fg.a1)) if (is.null(fg.a1)) args['col'] <- list(NULL) else args$col <- fg.a1[i];
if (!missing(lty)) if (is.null(lty)) args['lty'] <- list(NULL) else args$lty <- lty[i];
if (!missing(lwd)) if (is.null(lwd)) args['lwd'] <- list(NULL) else args$lwd <- lwd[i];
do.call(segments,c(args,...));
## a2 segment
args <- list(xc,yc,xs[length(xs)],ys[length(ys)]);
if (!missing(fg.a2)) if (is.null(fg.a2)) args['col'] <- list(NULL) else args$col <- fg.a2[i];
if (!missing(lty)) if (is.null(lty)) args['lty'] <- list(NULL) else args$lty <- lty[i];
if (!missing(lwd)) if (is.null(lwd)) args['lwd'] <- list(NULL) else args$lwd <- lwd[i];
do.call(segments,c(args,...));
## arc segment
args <- list(xs,ys);
if (!missing(fg.arc)) if (is.null(fg.arc)) args['col'] <- list(NULL) else args$col <- fg.arc[i];
if (!missing(lty)) if (is.null(lty)) args['lty'] <- list(NULL) else args$lty <- lty[i];
if (!missing(lwd)) if (is.null(lwd)) args['lwd'] <- list(NULL) else args$lwd <- lwd[i];
do.call(lines,c(args,...));
}; ## end for
}; ## end circle.sectors()
intersect.lines <- function(a1x,a1y,a2x,a2y,b1x,b1y,b2x,b2y) {
comb <- cbind(a1x,b1x,a2x,b2x,a1y,b1y,a2y,b2y);
comb <- array(comb,c(nrow(comb),2,2,2),dimnames=list(NULL,c('a','b'),NULL,c('x','y')));
any.points <- any(comb[,'a',1,'x'] == comb[,'a',2,'x'] & comb[,'a',1,'y'] == comb[,'a',2,'y']) || any(comb[,'b',1,'x'] == comb[,'b',2,'x'] & comb[,'b',1,'y'] == comb[,'b',2,'y']);
any.points[is.na(any.points)] <- F;
if (any.points) stop('coincident 1 and 2 points.');
m.a <- (comb[,'a',2,'y'] - comb[,'a',1,'y'])/(comb[,'a',2,'x'] - comb[,'a',1,'x']);
m.b <- (comb[,'b',2,'y'] - comb[,'b',1,'y'])/(comb[,'b',2,'x'] - comb[,'b',1,'x']);
b.a <- comb[,'a',1,'y'] - m.a*comb[,'a',1,'x'];
b.b <- comb[,'b',1,'y'] - m.b*comb[,'b',1,'x'];
a.inf <- is.infinite(m.a);
b.inf <- is.infinite(m.b);
parallel <- ifelse(a.inf,ifelse(b.inf,T,F),ifelse(b.inf,F,m.a == m.b));
x1equal <- comb[,'a',1,'x'] == comb[,'b',1,'x'];
coincident <- ifelse(a.inf,ifelse(b.inf,x1equal,F),ifelse(b.inf,F,parallel & b.a == b.b));
xi <- ifelse(coincident,Inf,ifelse(parallel,NaN,ifelse(a.inf,comb[,'a',1,'x'],ifelse(b.inf,comb[,'b',1,'x'],(b.b - b.a)/(m.a - m.b)))));
yi <- ifelse(coincident,Inf,ifelse(parallel,NaN,ifelse(a.inf,m.b*comb[,'a',1,'x'] + b.b,ifelse(b.inf,m.a*comb[,'b',1,'x'] + b.a,m.a*xi + b.a))));
xi[is.na(yi) & !is.nan(yi)] <- NA;
yi[is.na(xi) & !is.nan(xi)] <- NA;
cbind(x=xi,y=yi);
};
arrows.filled <- function(
x1,y1,x2=x1,y2=y1,a=tau/32,al=a,ar=a,len=sqrt(diff(par('usr')[3:4])^2+diff(par('usr')[1:2])^2)/20,lenl=len,lenr=len,fg,bg,bgl,bgr,lty,lwd,
fg.mainline,lty.mainline,lwd.mainline,
fg.tipline,lty.tipline,lwd.tipline,
fg.lwing,lty.lwing,lwd.lwing,
fg.rwing,lty.rwing,lwd.rwing,
fg.lcross,lty.lcross,lwd.lcross,
fg.rcross,lty.rcross,lwd.rcross,
...
) {
comb <- cbind(x1,y1,x2,y2,al,ar,lenl,lenr);
if (!missing(fg) && !is.null(fg)) fg <- rep(fg,len=nrow(comb));
if (!missing(lty) && !is.null(lty)) lty <- rep(lty,len=nrow(comb));
if (!missing(lwd) && !is.null(lwd)) lwd <- rep(lwd,len=nrow(comb));
if (!missing(fg.mainline) && !is.null(fg.mainline)) fg.mainline <- rep(fg.mainline,len=nrow(comb)) else if (missing(fg.mainline) && !missing(fg)) fg.mainline <- fg;
if (!missing(fg.tipline) && !is.null(fg.tipline)) fg.tipline <- rep(fg.tipline,len=nrow(comb)) else if (missing(fg.tipline) && !missing(fg)) fg.tipline <- fg;
if (!missing(fg.lwing) && !is.null(fg.lwing)) fg.lwing <- rep(fg.lwing,len=nrow(comb)) else if (missing(fg.lwing) && !missing(fg)) fg.lwing <- fg;
if (!missing(fg.rwing) && !is.null(fg.rwing)) fg.rwing <- rep(fg.rwing,len=nrow(comb)) else if (missing(fg.rwing) && !missing(fg)) fg.rwing <- fg;
if (!missing(fg.lcross) && !is.null(fg.lcross)) fg.lcross <- rep(fg.lcross,len=nrow(comb)) else if (missing(fg.lcross) && !missing(fg)) fg.lcross <- fg;
if (!missing(fg.rcross) && !is.null(fg.rcross)) fg.rcross <- rep(fg.rcross,len=nrow(comb)) else if (missing(fg.rcross) && !missing(fg)) fg.rcross <- fg;
if (!missing(lty.mainline) && !is.null(lty.mainline)) lty.mainline <- rep(lty.mainline,len=nrow(comb)) else if (missing(lty.mainline) && !missing(lty)) lty.mainline <- lty;
if (!missing(lty.tipline) && !is.null(lty.tipline)) lty.tipline <- rep(lty.tipline,len=nrow(comb)) else if (missing(lty.tipline) && !missing(lty)) lty.tipline <- lty;
if (!missing(lty.lwing) && !is.null(lty.lwing)) lty.lwing <- rep(lty.lwing,len=nrow(comb)) else if (missing(lty.lwing) && !missing(lty)) lty.lwing <- lty;
if (!missing(lty.rwing) && !is.null(lty.rwing)) lty.rwing <- rep(lty.rwing,len=nrow(comb)) else if (missing(lty.rwing) && !missing(lty)) lty.rwing <- lty;
if (!missing(lty.lcross) && !is.null(lty.lcross)) lty.lcross <- rep(lty.lcross,len=nrow(comb)) else if (missing(lty.lcross) && !missing(lty)) lty.lcross <- lty;
if (!missing(lty.rcross) && !is.null(lty.rcross)) lty.rcross <- rep(lty.rcross,len=nrow(comb)) else if (missing(lty.rcross) && !missing(lty)) lty.rcross <- lty;
if (!missing(lwd.mainline) && !is.null(lwd.mainline)) lwd.mainline <- rep(lwd.mainline,len=nrow(comb)) else if (missing(lwd.mainline) && !missing(lwd)) lwd.mainline <- lwd;
if (!missing(lwd.tipline) && !is.null(lwd.tipline)) lwd.tipline <- rep(lwd.tipline,len=nrow(comb)) else if (missing(lwd.tipline) && !missing(lwd)) lwd.tipline <- lwd;
if (!missing(lwd.lwing) && !is.null(lwd.lwing)) lwd.lwing <- rep(lwd.lwing,len=nrow(comb)) else if (missing(lwd.lwing) && !missing(lwd)) lwd.lwing <- lwd;
if (!missing(lwd.rwing) && !is.null(lwd.rwing)) lwd.rwing <- rep(lwd.rwing,len=nrow(comb)) else if (missing(lwd.rwing) && !missing(lwd)) lwd.rwing <- lwd;
if (!missing(lwd.lcross) && !is.null(lwd.lcross)) lwd.lcross <- rep(lwd.lcross,len=nrow(comb)) else if (missing(lwd.lcross) && !missing(lwd)) lwd.lcross <- lwd;
if (!missing(lwd.rcross) && !is.null(lwd.rcross)) lwd.rcross <- rep(lwd.rcross,len=nrow(comb)) else if (missing(lwd.rcross) && !missing(lwd)) lwd.rcross <- lwd;
if (!missing(bg) && !is.null(bg)) bg <- rep(bg,len=nrow(comb));
if (!missing(bgl) && !is.null(bgl)) bgl <- rep(bgl,len=nrow(comb)) else if (missing(bgl) && !missing(bg)) bgl <- bg;
if (!missing(bgr) && !is.null(bgr)) bgr <- rep(bgr,len=nrow(comb)) else if (missing(bgr) && !missing(bg)) bgr <- bg;
for (i in seq_len(nrow(comb))) {
x1c <- comb[i,'x1'];
y1c <- comb[i,'y1'];
x2c <- comb[i,'x2'];
y2c <- comb[i,'y2'];
alc <- comb[i,'al'];
arc <- comb[i,'ar'];
if (alc <= 0 || alc >= tau/2) stop(paste0('arrow ',i,' has invalid left angle ',alc,'.'));
if (arc <= 0 || arc >= tau/2) stop(paste0('arrow ',i,' has invalid right angle ',alc,'.'));
lenlc <- comb[i,'lenl'];
lenrc <- comb[i,'lenr'];
beta <- atan2(y2c-y1c,x2c-x1c);
xl <- x2c - lenlc*cos(beta - alc);
yl <- y2c - lenlc*sin(beta - alc);
xr <- x2c - lenrc*sin(tau/4 - beta - arc);
yr <- y2c - lenrc*cos(tau/4 - beta - arc);
with(as.data.frame(intersect.lines(x1c,y1c,x2c,y2c,xl,yl,xr,yr)),{ e <- parent.env(environment()); e$xi <- x; e$yi <- y; });
## mainline
args <- list(x1c,y1c,xi,yi);
if (!missing(fg.mainline)) if (is.null(fg.mainline)) args['col'] <- list(NULL) else args$col <- fg.mainline[i];
if (!missing(lty.mainline)) if (is.null(lty.mainline)) args['lty'] <- list(NULL) else args$lty <- lty.mainline[i];
if (!missing(lwd.mainline)) if (is.null(lwd.mainline)) args['lwd'] <- list(NULL) else args$lwd <- lwd.mainline[i];
do.call(segments,c(args,...));
## bg left
if (!missing(bgl) && !is.null(bgl)) {
bglc <- bgl[i];
polygon(c(x2c,xl,xi),c(y2c,yl,yi),border=NA,col=bglc);
}; ## end if
## bg right
if (!missing(bgr) && !is.null(bgr)) {
bgrc <- bgr[i];
polygon(c(x2c,xr,xi),c(y2c,yr,yi),border=NA,col=bgrc);
}; ## end if
## tipline -- only draw if at least one tipline arg was given
if (!missing(fg.tipline) || !missing(lty.tipline) || !missing(lwd.tipline)) {
args <- list(xi,yi,x2c,y2c);
if (!missing(fg.tipline)) if (is.null(fg.tipline)) args['col'] <- list(NULL) else args$col <- fg.tipline[i];
if (!missing(lty.tipline)) if (is.null(lty.tipline)) args['lty'] <- list(NULL) else args$lty <- lty.tipline[i];
if (!missing(lwd.tipline)) if (is.null(lwd.tipline)) args['lwd'] <- list(NULL) else args$lwd <- lwd.tipline[i];
do.call(segments,c(args,...));
}; ## end if
## lwing
args <- list(x2c,y2c,xl,yl);
if (!missing(fg.lwing)) if (is.null(fg.lwing)) args['col'] <- list(NULL) else args$col <- fg.lwing[i];
if (!missing(lty.lwing)) if (is.null(lty.lwing)) args['lty'] <- list(NULL) else args$lty <- lty.lwing[i];
if (!missing(lwd.lwing)) if (is.null(lwd.lwing)) args['lwd'] <- list(NULL) else args$lwd <- lwd.lwing[i];
do.call(segments,c(args,...));
## rwing
args <- list(x2c,y2c,xr,yr);
if (!missing(fg.rwing)) if (is.null(fg.rwing)) args['col'] <- list(NULL) else args$col <- fg.rwing[i];
if (!missing(lty.rwing)) if (is.null(lty.rwing)) args['lty'] <- list(NULL) else args$lty <- lty.rwing[i];
if (!missing(lwd.rwing)) if (is.null(lwd.rwing)) args['lwd'] <- list(NULL) else args$lwd <- lwd.rwing[i];
do.call(segments,c(args,...));
## lcross
args <- list(xl,yl,xi,yi);
if (!missing(fg.lcross)) if (is.null(fg.lcross)) args['col'] <- list(NULL) else args$col <- fg.lcross[i];
if (!missing(lty.lcross)) if (is.null(lty.lcross)) args['lty'] <- list(NULL) else args$lty <- lty.lcross[i];
if (!missing(lwd.lcross)) if (is.null(lwd.lcross)) args['lwd'] <- list(NULL) else args$lwd <- lwd.lcross[i];
do.call(segments,c(args,...));
## rcross
args <- list(xr,yr,xi,yi);
if (!missing(fg.rcross)) if (is.null(fg.rcross)) args['col'] <- list(NULL) else args$col <- fg.rcross[i];
if (!missing(lty.rcross)) if (is.null(lty.rcross)) args['lty'] <- list(NULL) else args$lty <- lty.rcross[i];
if (!missing(lwd.rcross)) if (is.null(lwd.rcross)) args['lwd'] <- list(NULL) else args$lwd <- lwd.rcross[i];
do.call(segments,c(args,...));
}; ## end for
}; ## end arrows.filled()
## basic plot outline
par(xaxs='i',yaxs='i');
xlim <- c(0,8);
ylim <- c(0,6);
extra <- 0.5;
plot(NA,xlim=xlim+extra*c(-1,1),ylim=ylim+extra*c(-1,1),axes=F,ann=F);
## custom axes
xtick <- 0:8;
ytick <- 0:6;
tick.len <- 0.06;
tick.zeroadd <- 0.1;
segments(xtick,0,xtick,-tick.len,lwd=2);
segments(0,ytick,-tick.len,ytick,lwd=2);
abline(h=0,lwd=2);
abline(v=0,lwd=2);
text(xtick[-1],-tick.len/2,xtick[-1],pos=1,font=2);
text(xtick[1]+tick.zeroadd,-tick.len/2,xtick[1],pos=1,font=2);
text(-tick.len/2,ytick[-1],ytick[-1],pos=2,font=2);
text(-tick.len/2,ytick[1]+tick.zeroadd,ytick[1],pos=2,font=2);
## define main points
V1 <- c(2,5);
V2 <- c(7,1);
## circle sector with label
V1.angle <- atan2(V1[2],V1[1]);
V2.angle <- atan2(V2[2],V2[1]);
sector.radius <- 2;
circle.sectors(0,0,sector.radius,V1.angle,V2.angle,'#277A27','#E5EFE5',lwd=2);
label.radius <- 1.1;
label.angle <- mean(c(V1.angle,V2.angle));
text(label.radius*cos(label.angle),label.radius*sin(label.angle),'α',family='serif',cex=1.3,col='#277A27');
## arrows
arrows.filled(0,0,V1[1],V1[2],a=tau*12/360,len=0.25,lwd=2,bg='black');
arrows.filled(0,0,V2[1],V2[2],a=tau*12/360,len=0.25,lwd=2,bg='black');
## point circles
circles(c(V1[1],V2[1]),c(V1[2],V2[2]),0.08,'black','blue');
## point labels
text(V1[1]+0.03,V1[2]+0.2,sprintf('V1 = (%d,%d)',V1[1],V1[2]),pos=4,col='blue',font=2,family='sans');
text(V2[1]+0.05,V2[2]-0.2,sprintf('V2 = (%d,%d)',V2[1],V2[2]),pos=4,col='blue',font=2,family='sans');
这篇关于绘制向量之间的角度的文章就介绍到这了，希望我们推荐的答案对大家有所帮助，也希望大家多多支持IT屋！
查看全文
