Skip to content

Commit ee322ca

Browse files
tobistetobiste
committed
added a few tests
1 parent e37df81 commit ee322ca

17 files changed

+210
-148
lines changed

‎DESCRIPTION

Lines changed: 3 additions & 1 deletion
Original file line numberDiff line numberDiff line change
@@ -33,11 +33,13 @@ Imports:
3333
Suggests:
3434
knitr,
3535
mapproj,
36-
rmarkdown
36+
rmarkdown,
37+
testthat (>= 3.0.0)
3738
VignetteBuilder:
3839
knitr
3940
Encoding: UTF-8
4041
Language: en-US
4142
LazyData: true
4243
Roxygen: list(markdown = TRUE)
4344
RoxygenNote: 7.3.1
45+
Config/testthat/edition: 3

‎NAMESPACE

Lines changed: 1 addition & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -160,6 +160,7 @@ importFrom(sf,st_is)
160160
importFrom(sf,st_make_grid)
161161
importFrom(sf,st_transform)
162162
importFrom(stats,aggregate)
163+
importFrom(stats,qf)
163164
importFrom(tectonicr,deg2rad)
164165
importFrom(tectonicr,dist_greatcircle)
165166
importFrom(tectonicr,rad2deg)

‎R/alphabeta.R

Lines changed: 5 additions & 2 deletions
Original file line numberDiff line numberDiff line change
@@ -10,20 +10,23 @@
1010
#' @param alpha numeric vector. Alpha angle in degrees
1111
#' @param beta numeric vector. Beta angle in degrees
1212
#' @param gamma numeric. (optional). Gamma angle in degrees
13+
#'
14+
#' @export
15+
#'
1316
#' @return object of calss `"plane"`. If gamma is specified, `"line"` object is
1417
#' returned.
18+
#'
1519
#' @examples
1620
#' azi <- 225
1721
#' inc <- -45
1822
#' drillcore_orientation(azi, inc, 60, 320)
19-
#' drillcore_orientation(azi, inc, 45, 220, )
23+
#' drillcore_orientation(azi, inc, 45, 220)
2024
#'
2125
#' # multiple alpha-beta measurements
2226
#' stereoplot()
2327
#' stereo_point(Line(azi, -inc), lab = "CA")
2428
#' drillcore_orientation(azi, inc, alpha = c(60, 45), beta = c(320, 220)) |>
2529
#' stereo_point(lab = c("A", "B"))
26-
#' @export
2730
drillcore_orientation <- function(azi, inc, alpha, beta, gamma = NULL) {
2831
stopifnot(length(alpha) == length(beta))
2932
inc <- -inc

‎R/fabric_plots.R

Lines changed: 128 additions & 126 deletions
Original file line numberDiff line numberDiff line change
@@ -1,122 +1,122 @@
1-
# Create a ternary plot from a data frame
2-
ternaryPlot <- function(x, plotPoints = TRUE, labels = c("", "", ""), grid = TRUE, increment = 20, ...) {
3-
ternaryTriangle()
4-
ternaryLabels(labels[1], labels[2], labels[3])
5-
if (grid == TRUE) {
6-
ternaryGrid(increment)
7-
}
8-
if (plotPoints == TRUE) {
9-
ternaryPoints(x, ...)
10-
}
11-
}
12-
13-
# Add points from a data frame to an existing ternary plot
14-
ternaryPoints <- function(x, ...) {
15-
x <- validatedTernaryPoints(x)
16-
coords <- cartesianFromTernary(x[, 1], x[, 2], x[, 3])
17-
graphics::points(coords$x, coords$y, ...)
18-
}
19-
20-
# Add a line segment to an existing ternary plot
21-
# Color and line type may be added as additional arguments
22-
ternarySegment <- function(x0, x1, ...) {
23-
# x0 and x1 are vectors of the endpoint ternary coordinates
24-
coords0 <- cartesianFromTernary(x0[1], x0[2], x0[3])
25-
coords1 <- cartesianFromTernary(x1[1], x1[2], x1[3])
26-
graphics::segments(coords0$x, coords0$y, coords1$x, coords1$y, ...)
27-
}
28-
29-
# Add a polygon to an existing ternary plot
30-
# Color may be added as an additional argument
31-
ternaryPolygon <- function(x, ...) {
32-
nPoints <- nrow(x)
33-
xCoord <- vector(mode = "numeric", length = nPoints)
34-
yCoord <- vector(mode = "numeric", length = nPoints)
35-
for (i in 1:nPoints) {
36-
coords <- cartesianFromTernary(x[i, 1], x[i, 2], x[i, 3])
37-
xCoord[i] <- coords$x
38-
yCoord[i] <- coords$y
39-
}
40-
graphics::polygon(xCoord, yCoord, ...)
41-
}
42-
43-
# Add text to an existing ternary plot
44-
# Text styling may be added as additional arguments
45-
ternaryText <- function(x, label = "", ...) {
46-
coords <- cartesianFromTernary(x[1], x[2], x[3])
47-
graphics::text(coords$x, coords$y, label = label, ...)
48-
}
49-
50-
# ---------------------------------------------------------------------------------------
51-
# The following functions are called by ternaryPlot() and generally will not need to be
52-
# called directly
53-
54-
## Plotting primitives -------------------------------------------------------------------
55-
ternaryTriangle <- function() {
56-
top <- cartesianFromTernary(100, 0, 0)
57-
left <- cartesianFromTernary(0, 100, 0)
58-
right <- cartesianFromTernary(0, 0, 100)
59-
lim <- c(-1.1, 1.1)
60-
graphics::plot(top$x, top$y, xlim = lim, ylim = lim, type = "n", asp = 1, axes = FALSE, xlab = "", ylab = "")
61-
graphics::segments(top$x, top$y, right$x, right$y)
62-
graphics::segments(top$x, top$y, left$x, left$y)
63-
graphics::segments(left$x, left$y, right$x, right$y)
64-
}
65-
66-
ternaryLabels <- function(top = "", left = "", right = "") {
67-
topCoord <- cartesianFromTernary(100, 0, 0)
68-
leftCoord <- cartesianFromTernary(0, 100, 0)
69-
rightCoord <- cartesianFromTernary(0, 0, 100)
70-
graphics::text(topCoord$x, topCoord$y, top, pos = 3)
71-
graphics::text(leftCoord$x, leftCoord$y, left, pos = 1, srt = -60)
72-
graphics::text(rightCoord$x, rightCoord$y, right, pos = 1, srt = 60)
73-
}
74-
75-
ternaryGrid <- function(increment) {
76-
low <- increment
77-
high <- 100 - increment
78-
79-
m <- seq(low, high, increment)
80-
nLines <- length(m)
81-
82-
n1 <- o2 <- seq(high, low, -increment)
83-
n2 <- o1 <- rep(0, nLines)
84-
85-
for (i in 1:nLines) {
86-
a <- cartesianFromTernary(m[i], n1[i], o1[i])
87-
b <- cartesianFromTernary(m[i], n2[i], o2[i])
88-
graphics::segments(a$x, a$y, b$x, b$y, col = "lightgray", lty = 3)
89-
90-
a <- cartesianFromTernary(n1[i], m[i], o1[i])
91-
b <- cartesianFromTernary(n2[i], m[i], o2[i])
92-
graphics::segments(a$x, a$y, b$x, b$y, col = "lightgray", lty = 3)
93-
94-
a <- cartesianFromTernary(n1[i], o1[i], m[i])
95-
b <- cartesianFromTernary(n2[i], o2[i], m[i])
96-
graphics::segments(a$x, a$y, b$x, b$y, col = "lightgray", lty = 3)
97-
}
98-
}
99-
100-
## Convert from ternary coordinates to cartesian (x, y) coordinates ----------------------
101-
cartesianFromTernary <- function(top, left, right) {
102-
y <- (top - 50) / 50 # vertically spans from -1 to 1
103-
baseHalfWidth <- 2 / tan(60 * pi / 180) # : equilateral triangle
104-
horizontalHalfWidth <- ((100 - top) * baseHalfWidth) / 100
105-
horizontalProportion <- (right / (right + left + 0.0000001) - 0.5) * 2
106-
x <- horizontalProportion * horizontalHalfWidth
107-
xyCoords <- data.frame(cbind(x = x, y = y))
108-
colnames(xyCoords) <- c("x", "y")
109-
xyCoords
110-
}
111-
112-
## Remove rows with NA values and rows that don't sum to 100 -----------------------------
113-
validatedTernaryPoints <- function(x) {
114-
rowsWithNA <- rowSums(is.na(x))
115-
xNAremoved <- x[rowsWithNA == 0, ]
116-
rowsEqualing100 <- abs(rowSums(xNAremoved) - 100) <= 2
117-
xFinal <- xNAremoved[rowsEqualing100, ]
118-
xFinal
119-
}
1+
# # Create a ternary plot from a data frame
2+
# ternaryPlot <- function(x, plotPoints = TRUE, labels = c("", "", ""), grid = TRUE, increment = 20, ...) {
3+
# ternaryTriangle()
4+
# ternaryLabels(labels[1], labels[2], labels[3])
5+
# if (grid == TRUE) {
6+
# ternaryGrid(increment)
7+
# }
8+
# if (plotPoints == TRUE) {
9+
# ternaryPoints(x, ...)
10+
# }
11+
# }
12+
#
13+
# # Add points from a data frame to an existing ternary plot
14+
# ternaryPoints <- function(x, ...) {
15+
# x <- validatedTernaryPoints(x)
16+
# coords <- cartesianFromTernary(x[, 1], x[, 2], x[, 3])
17+
# graphics::points(coords$x, coords$y, ...)
18+
# }
19+
#
20+
# # Add a line segment to an existing ternary plot
21+
# # Color and line type may be added as additional arguments
22+
# ternarySegment <- function(x0, x1, ...) {
23+
# # x0 and x1 are vectors of the endpoint ternary coordinates
24+
# coords0 <- cartesianFromTernary(x0[1], x0[2], x0[3])
25+
# coords1 <- cartesianFromTernary(x1[1], x1[2], x1[3])
26+
# graphics::segments(coords0$x, coords0$y, coords1$x, coords1$y, ...)
27+
# }
28+
#
29+
# # Add a polygon to an existing ternary plot
30+
# # Color may be added as an additional argument
31+
# ternaryPolygon <- function(x, ...) {
32+
# nPoints <- nrow(x)
33+
# xCoord <- vector(mode = "numeric", length = nPoints)
34+
# yCoord <- vector(mode = "numeric", length = nPoints)
35+
# for (i in 1:nPoints) {
36+
# coords <- cartesianFromTernary(x[i, 1], x[i, 2], x[i, 3])
37+
# xCoord[i] <- coords$x
38+
# yCoord[i] <- coords$y
39+
# }
40+
# graphics::polygon(xCoord, yCoord, ...)
41+
# }
42+
#
43+
# # Add text to an existing ternary plot
44+
# # Text styling may be added as additional arguments
45+
# ternaryText <- function(x, label = "", ...) {
46+
# coords <- cartesianFromTernary(x[1], x[2], x[3])
47+
# graphics::text(coords$x, coords$y, label = label, ...)
48+
# }
49+
#
50+
# # ---------------------------------------------------------------------------------------
51+
# # The following functions are called by ternaryPlot() and generally will not need to be
52+
# # called directly
53+
#
54+
# ## Plotting primitives -------------------------------------------------------------------
55+
# ternaryTriangle <- function() {
56+
# top <- cartesianFromTernary(100, 0, 0)
57+
# left <- cartesianFromTernary(0, 100, 0)
58+
# right <- cartesianFromTernary(0, 0, 100)
59+
# lim <- c(-1.1, 1.1)
60+
# graphics::plot(top$x, top$y, xlim = lim, ylim = lim, type = "n", asp = 1, axes = FALSE, xlab = "", ylab = "")
61+
# graphics::segments(top$x, top$y, right$x, right$y)
62+
# graphics::segments(top$x, top$y, left$x, left$y)
63+
# graphics::segments(left$x, left$y, right$x, right$y)
64+
# }
65+
#
66+
# ternaryLabels <- function(top = "", left = "", right = "") {
67+
# topCoord <- cartesianFromTernary(100, 0, 0)
68+
# leftCoord <- cartesianFromTernary(0, 100, 0)
69+
# rightCoord <- cartesianFromTernary(0, 0, 100)
70+
# graphics::text(topCoord$x, topCoord$y, top, pos = 3)
71+
# graphics::text(leftCoord$x, leftCoord$y, left, pos = 1, srt = -60)
72+
# graphics::text(rightCoord$x, rightCoord$y, right, pos = 1, srt = 60)
73+
# }
74+
#
75+
# ternaryGrid <- function(increment) {
76+
# low <- increment
77+
# high <- 100 - increment
78+
#
79+
# m <- seq(low, high, increment)
80+
# nLines <- length(m)
81+
#
82+
# n1 <- o2 <- seq(high, low, -increment)
83+
# n2 <- o1 <- rep(0, nLines)
84+
#
85+
# for (i in 1:nLines) {
86+
# a <- cartesianFromTernary(m[i], n1[i], o1[i])
87+
# b <- cartesianFromTernary(m[i], n2[i], o2[i])
88+
# graphics::segments(a$x, a$y, b$x, b$y, col = "lightgray", lty = 3)
89+
#
90+
# a <- cartesianFromTernary(n1[i], m[i], o1[i])
91+
# b <- cartesianFromTernary(n2[i], m[i], o2[i])
92+
# graphics::segments(a$x, a$y, b$x, b$y, col = "lightgray", lty = 3)
93+
#
94+
# a <- cartesianFromTernary(n1[i], o1[i], m[i])
95+
# b <- cartesianFromTernary(n2[i], o2[i], m[i])
96+
# graphics::segments(a$x, a$y, b$x, b$y, col = "lightgray", lty = 3)
97+
# }
98+
# }
99+
#
100+
# ## Convert from ternary coordinates to cartesian (x, y) coordinates ----------------------
101+
# cartesianFromTernary <- function(top, left, right) {
102+
# y <- (top - 50) / 50 # vertically spans from -1 to 1
103+
# baseHalfWidth <- 2 / tan(60 * pi / 180) # : equilateral triangle
104+
# horizontalHalfWidth <- ((100 - top) * baseHalfWidth) / 100
105+
# horizontalProportion <- (right / (right + left + 0.0000001) - 0.5) * 2
106+
# x <- horizontalProportion * horizontalHalfWidth
107+
# xyCoords <- data.frame(cbind(x = x, y = y))
108+
# colnames(xyCoords) <- c("x", "y")
109+
# xyCoords
110+
# }
111+
#
112+
# ## Remove rows with NA values and rows that don't sum to 100 -----------------------------
113+
# validatedTernaryPoints <- function(x) {
114+
# rowsWithNA <- rowSums(is.na(x))
115+
# xNAremoved <- x[rowsWithNA == 0, ]
116+
# rowsEqualing100 <- abs(rowSums(xNAremoved) - 100) <= 2
117+
# xFinal <- xNAremoved[rowsEqualing100, ]
118+
# xFinal
119+
# }
120120

121121
# Fabric intensities and plots -------------------------------------------------
122122

@@ -127,15 +127,17 @@ validatedTernaryPoints <- function(x) {
127127
#'
128128
#' @returns numeric vector containing the fabric shape and intensity indices:
129129
#' \describe{
130-
#' \item{`P`}{Point (Vollmer 1990), range: (0, 1)}
131-
#' \item{`G`}{Girdle (Vollmer 1990), range: (0, 1)}
132-
#' \item{`R`}{Random (Vollmer 1990), range: (0, 1)}
133-
#' \item{`B`}{cylindricity (Vollmer 1990), range: (0, 1)}
134-
#' \item{`C`}{cylindricity or Fabric strength (Woodcock 1977), range: (0, Inf)}
135-
#' \item{`I`}{cylindricity or Fabric intensity (Lisle 1985), range: (0, 5)}
136-
#' \item{`D`}{"distance" from uniformity, linear from R to P, and R to G. End members are: uniform D = 0, girdle D = 0.5, cluster D = 1. The 99% level for a test against uniformity for a sample size of 300 is D = 0.1 (Vollmer 2020).}
130+
#' \item{`P`}{Point (Vollmer 1990). Range: (0, 1)}
131+
#' \item{`G`}{Girdle (Vollmer 1990). Range: (0, 1)}
132+
#' \item{`R`}{Random (Vollmer 1990). Range: (0, 1)}
133+
#' \item{`B`}{cylindricity (Vollmer 1990). Range: (0, 1)}
134+
#' \item{`C`}{cylindricity or Fabric strength (Woodcock 1977). Rrange: (0, Inf)}
135+
#' \item{`I`}{cylindricity or Fabric intensity (Lisle 1985). Range: (0, 5)}
136+
#' \item{`D`}{"distance" from uniformity, linear from R to P, and R to G (Vollmer 2020). Range: (0, 1). End members are: uniform D = 0, girdle D = 0.5, cluster D = 1. The 99% level for a test against uniformity for a sample size of 300 is D = 0.1.}
137137
#' }
138138
#' @export
139+
#'
140+
#' @seealso [or_shape_params()]
139141
#'
140142
#' @examples
141143
#' set.seed(1)

‎R/gg_stereonet.R

Lines changed: 2 additions & 1 deletion
Original file line numberDiff line numberDiff line change
@@ -28,7 +28,8 @@
2828
#' x2 <- Line(120, 5)
2929
#' ggstereo() +
3030
#' ggplot2::geom_point(data = gg(x2), ggplot2::aes(x, y), color = "darkgreen") +
31-
#' ggplot2::geom_path(data = ggl(x2, d = 8), ggplot2::aes(x, y, group = group), color = "darkgreen")
31+
#' ggplot2::geom_path(data = ggl(x2, d = 8),
32+
#' ggplot2::aes(x, y, group = group), color = "darkgreen")
3233
#'
3334
#' x3 <- Plane(137, 71)
3435
#' ggstereo() +

‎R/math.R

Lines changed: 7 additions & 5 deletions
Original file line numberDiff line numberDiff line change
@@ -740,8 +740,8 @@ fisher_statistics <- function(x, w = NULL, p = 0.05) {
740740
#' set.seed(1234)
741741
#' x <- rfb(100, mu = Line(120, 50), k = 15, A = diag(c(-5, 0, 5)))
742742
#'
743-
#' ggstereo() +
744-
#' geom_point(data = gg(x), aes(x, y))
743+
#' stereoplot()
744+
#' stereo_point(x)
745745
#'
746746
#' bingham_statistics(x)
747747
bingham_statistics <- function(x, w = NULL) {
@@ -790,15 +790,17 @@ bingham_statistics <- function(x, w = NULL) {
790790
#' @returns list indicating the F-statistic and the p-value.
791791
#'
792792
#' @export
793+
#'
794+
#' @importFrom stats qf
793795
#'
794796
#' @examples
795797
#' set.seed(1234)
796798
#' x <- rvmf(100, mu = Line(120, 50), k = 20)
797799
#' y <- rvmf(100, mu = Line(180, 45), k = 20)
798800
#'
799801
#' ggstereo() +
800-
#' geom_point(data = gg(x), aes(x, y, color = "x")) +
801-
#' geom_point(data = gg(y), aes(x, y, color = "y"))
802+
#' ggplot2::geom_point(data = gg(x), ggplot2::aes(x, y, color = "x")) +
803+
#' ggplot2::geom_point(data = gg(y), ggplot2::aes(x, y, color = "y"))
802804
#'
803805
#' fisher_ftest(x, y)
804806
fisher_ftest <- function(x, y, alpha = 0.05) {
@@ -828,7 +830,7 @@ fisher_ftest <- function(x, y, alpha = 0.05) {
828830
df1 <- 2
829831
df2 <- 2 * (nx + ny - 2)
830832

831-
crit <- qf(p = alpha, df1 = df1, df2 = df2, lower.tail = FALSE)
833+
crit <- stats::qf(p = alpha, df1 = df1, df2 = df2, lower.tail = FALSE)
832834
if (stat > crit) {
833835
message("Reject null-hypothesis")
834836
} else {

‎man/bingham_statistics.Rd

Lines changed: 2 additions & 2 deletions
Some generated files are not rendered by default. Learn more about customizing how changed files appear on GitHub.

‎man/drillcore_orientation.Rd

Lines changed: 1 addition & 1 deletion
Some generated files are not rendered by default. Learn more about customizing how changed files appear on GitHub.

0 commit comments

Comments
 (0)