1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
|
#############################################################
# #
# points.circular function #
# Author: Claudio Agostinelli #
# E-mail: claudio@unive.it #
# Date: August, 08, 2014 #
# Version: 0.4 #
# #
# Copyright (C) 2014 Claudio Agostinelli #
# #
#############################################################
points.circular <- function(x, pch = 16, cex = 1, stack = FALSE, start.sep=0, sep = 0.025, shrink=1, bins=NULL, col=NULL, next.points=NULL, plot.info=NULL, zero=NULL, rotation=NULL, ...) {
if (is.matrix(x) | is.data.frame(x)) {
nseries <- ncol(x)
} else {
nseries <- 1
}
xx <- as.data.frame(x)
xcircularp <- attr(as.circular(xx[,1]), "circularp")
type <- xcircularp$type
modulo <- xcircularp$modulo
if (is.null(plot.info)) {
if (is.null(zero))
zero <- xcircularp$zero
if (is.null(rotation))
rotation <- xcircularp$rotation
if (is.null(next.points))
next.points <- 0
} else {
zero <- plot.info$zero
rotation <- plot.info$rotation
if (is.null(next.points))
next.points <- plot.info$next.points
}
if (is.null(bins)) {
bins <- NROW(x)
} else {
bins <- round(bins)
if (bins<=0)
stop("bins must be non negative")
}
if (is.null(col)) {
col <- seq(nseries)
} else {
if (length(col)!=nseries) {
col <- rep(col, nseries)[1:nseries]
}
}
pch <- rep(pch, nseries, length.out=nseries)
for (iseries in 1:nseries) {
x <- xx[,iseries]
x <- na.omit(x)
n <- length(x)
if (n) {
x <- conversion.circular(x, units="radians")
attr(x, "circularp") <- attr(x, "class") <- NULL
if (rotation=="clock")
x <- -x
x <- x+zero
x <- x%%(2*pi)
PointsCircularRad(x, bins, stack, col, pch, iseries, nseries, start.sep, sep, next.points, shrink, cex, ...)
}
}
return(invisible(list(zero=zero, rotation=rotation, next.points=next.points+nseries*sep)))
}
PointsCircularRad <- function(x, bins, stack, col, pch, iseries, nseries, start.sep, sep, next.points, shrink, cex, ...) {
#### x musts be in modulo 2pi
if (!stack) {
z <- cos(x)
y <- sin(x)
r <- 1+((iseries-1)*sep+next.points+start.sep)*shrink
points.default(z*r, y*r, cex=cex, pch=pch[iseries], col = col[iseries], ...)
} else {
x[x >= 2*pi] <- 2*pi-4*.Machine$double.eps
arc <- (2 * pi)/bins
pos.bins <- ((1:nseries)-1/2)*arc/nseries-arc/2
# bins.count <- c(1:bins)
# for (i in 1:bins) {
# bins.count[i] <- sum(x < i * arc & x >= (i - 1) * arc)
# }
breaks <- seq(0,2*pi,length.out=(bins+1))
bins.count <- hist.default(x, breaks=breaks, plot=FALSE, right=TRUE)$counts
###### TO BE USED IN THE FUTURE .C("bincount", x, as.integer(length(x)), seq(0,2*pi,length.out=bins), as.integer(bins+1), counts = integer(bins), right = as.logical(TRUE), include = as.logical(FALSE), naok = FALSE, NAOK = FALSE, DUP = FALSE, PACKAGE = "base")$counts
mids <- seq(arc/2, 2 * pi - pi/bins, length = bins) + pos.bins[iseries]
index <- cex*sep
for (i in 1:bins) {
if (bins.count[i] != 0) {
for (j in 0:(bins.count[i] - 1)) {
r <- 1 + start.sep + j * index
z <- r * cos(mids[i])
y <- r * sin(mids[i])
points.default(z, y, cex=cex, pch=pch[iseries], col=col[iseries], ...)
}
}
}
}
}
|
