From 33d83f3a9fecbd40d53eebf009dfc0983f7a47e1 Mon Sep 17 00:00:00 2001
From: Tobias Stephan <73840881+tobiste@users.noreply.github.com>
Date: Sun, 8 Dec 2024 17:05:34 -0500
Subject: [PATCH] weightings added

---
 NAMESPACE                |  1 +
 R/gg_stereonet.R         |  5 ++--
 R/math.R                 | 58 +++++++++++++++++++++++++---------------
 man/fisher_statistics.Rd |  4 +--
 man/stats.Rd             |  9 ++++---
 man/vslerp.Rd            |  2 +-
 6 files changed, 48 insertions(+), 31 deletions(-)

diff --git a/NAMESPACE b/NAMESPACE
index d3b3d1b..dd7ca71 100644
--- a/NAMESPACE
+++ b/NAMESPACE
@@ -38,6 +38,7 @@ export(fabric_indexes)
 export(fault_analysis)
 export(fault_from_rake)
 export(fault_rake)
+export(fisher_statistics)
 export(geom_contour_stereo)
 export(geom_contourf_stereo)
 export(gg)
diff --git a/R/gg_stereonet.R b/R/gg_stereonet.R
index 6b52113..ba8727e 100644
--- a/R/gg_stereonet.R
+++ b/R/gg_stereonet.R
@@ -242,13 +242,14 @@ ggstereo <- function(data = NULL, mapping = aes(), earea = TRUE, centercross = T
       title = element_text(element_text(face = "bold")),
       panel.background = element_blank(), 
       panel.border = element_blank(),
+      panel.grid = element_blank(),
       axis.ticks = element_blank(), 
       axis.title = element_blank(), 
       axis.text = element_blank(),
-      legend.title = element_blank()
+      #legend.title = element_blank()
     ) +    {
       if (grid) {
-        ggstereo_grid(d = grid.spacing, rot = grid.rot, color = "lightgrey", lwd = .25)
+        ggstereo_grid(d = grid.spacing, rot = grid.rot, color = "grey90", lwd = .2)
       }
     } +
     ggframe(...) +
diff --git a/R/math.R b/R/math.R
index 6c31ac0..aa9ecec 100644
--- a/R/math.R
+++ b/R/math.R
@@ -437,13 +437,13 @@ vresultant <- function(x, w = NULL, mean = FALSE) {
 #' @name stats
 #' @examples
 #' x <- rvmf(100, mu = Line(120, 50), k = 5)
-
 #' v_var(x)
 #' v_delta(x)
 #' v_rdegree(x)
 #' v_sde(x)
 #' v_confidence_angle(x)
 #' estimate_k(x)
+#' fisher_statistics(x)
 #'
 #' #' weights:
 #' x2 <-  Line(c(0, 0), c(0, 90))
@@ -535,14 +535,21 @@ v_delta <- function(x, w = NULL) {
 
 #' @rdname stats
 #' @export
-v_rdegree <- function(x) {
+v_rdegree <- function(x, w = NULL) {
   if (is.spherical(x)) {
     v <- to_vec(x)
   } else {
     v <- vec2mat(x)
   }
-  N <- nrow(v)
-  Rbar <- vresultant(vnorm(v), mean = FALSE) |>
+  #N <- nrow(v)
+  w <- if (is.null(w)) {
+    rep(1, times = nrow(v))
+  } else {
+    as.numeric(w)
+  }
+  
+  N <- sum(w)
+  Rbar <- vresultant(vnorm(v), w, mean = FALSE) |>
     vlength()
 
   100 * (2 * Rbar - N) / N
@@ -550,15 +557,22 @@ v_rdegree <- function(x) {
 
 #' @rdname stats
 #' @export
-v_sde <- function(x) {
+v_sde <- function(x, w = NULL) {
   if (is.spherical(x)) {
     v <- to_vec(x)
   } else {
     v <- vec2mat(x)
   }
-  N <- nrow(v)
+  w <- if (is.null(w)) {
+    rep(1, times = nrow(v))
+  } else {
+    as.numeric(w)
+  }
+  
+  N <- sum(w)
+  
   if (N < 25) warning("The standard error might not be a good estimator for N < 25")
-  xbar <- vsum(v) / N
+  xbar <- vsum(v, w) / N
   Rbar <- vlength(xbar)
   mu <- xbar / Rbar
 
@@ -576,7 +590,7 @@ v_sde <- function(x) {
 
 #' @rdname stats
 #' @export
-v_confidence_angle <- function(x, alpha = 0.05) {
+v_confidence_angle <- function(x, w = NULL, alpha = 0.05) {
   if (is.spherical(x)) {
     v <- to_vec(x)
   } else {
@@ -584,7 +598,7 @@ v_confidence_angle <- function(x, alpha = 0.05) {
   }
 
   e_alpha <- -log(alpha)
-  q <- asin(sqrt(e_alpha) * v_sde(v))
+  q <- asin(sqrt(e_alpha) * v_sde(v, w))
 
   if (is.spherical(x)) {
     rad2deg(q)
@@ -616,16 +630,13 @@ v_antipode <- function(x) {
 
 #' @rdname stats
 #' @export
-estimate_k <- function(x) {
+estimate_k <- function(x, w = NULL) {
   if (is.spherical(x)) {
     v <- to_vec(x)
   } else {
     v <- vec2mat(x)
   }
-  # N <- nrow(v)
-  # xbar <- vsum(v) / N
-  # Rbar <- vlength(xbar)
-  Rbar <- vresultant(v, mean = TRUE) |>
+  Rbar <- vresultant(v, w = w, mean = TRUE) |>
     vlength()
 
   p <- 3
@@ -647,12 +658,11 @@ estimate_k <- function(x) {
 #' \item{`"csd"`}{estimated angular standard deviation}
 #' \item{`"a95"`}{confidence limit}
 #' }
+#' @export
 #' @examples
-#' \dontrun{
 #' x <- rvmf(100, mu = Line(120, 50), k = 5)
 #' fisher_statistics(x)
-#' }
-fisher_statistics <- function(x) {
+fisher_statistics <- function(x, w = NULL) {
   transform <- FALSE
   if (is.spherical(x)) {
     x <- to_vec(x)
@@ -660,9 +670,15 @@ fisher_statistics <- function(x) {
   } else {
     x <- vec2mat(x)
   }
-  N <- nrow(x)
-  R <- x |>
-    vresultant() |>
+  w <- if (is.null(w)) {
+    rep(1, times = nrow(x))
+  } else {
+    as.numeric(w)
+  }
+  
+  N <- sum(w)
+  
+  R <- vresultant(x, w) |>
     vlength()
 
   if (N != R) {
@@ -686,7 +702,7 @@ fisher_statistics <- function(x) {
 #' @note For non-unit vectors the interpolation is not uniform
 #' @details
 #' A Slerp path is the spherical geometry equivalent of a path along a line
-#' segment in the plane; a great circle is a spherical geodesic. #'
+#' segment in the plane; a great circle is a spherical geodesic. 
 #' @export
 vslerp <- function(x, y, t) {
   transform <- FALSE
diff --git a/man/fisher_statistics.Rd b/man/fisher_statistics.Rd
index 8d3d61a..f13b356 100644
--- a/man/fisher_statistics.Rd
+++ b/man/fisher_statistics.Rd
@@ -4,7 +4,7 @@
 \alias{fisher_statistics}
 \title{Fisher's statistics}
 \usage{
-fisher_statistics(x)
+fisher_statistics(x, w = NULL)
 }
 \arguments{
 \item{x}{numeric. Can be three element vector, three column array, or an
@@ -24,8 +24,6 @@ Estimates concentration parameter, angular standard deviation, and
 confidence limit.
 }
 \examples{
-\dontrun{
 x <- rvmf(100, mu = Line(120, 50), k = 5)
 fisher_statistics(x)
 }
-}
diff --git a/man/stats.Rd b/man/stats.Rd
index d35fe50..494b916 100644
--- a/man/stats.Rd
+++ b/man/stats.Rd
@@ -17,13 +17,13 @@ v_var(x, w = NULL)
 
 v_delta(x, w = NULL)
 
-v_rdegree(x)
+v_rdegree(x, w = NULL)
 
-v_sde(x)
+v_sde(x, w = NULL)
 
-v_confidence_angle(x, alpha = 0.05)
+v_confidence_angle(x, w = NULL, alpha = 0.05)
 
-estimate_k(x)
+estimate_k(x, w = NULL)
 }
 \arguments{
 \item{x}{numeric. Can be three element vector, three column array, or an
@@ -68,6 +68,7 @@ v_rdegree(x)
 v_sde(x)
 v_confidence_angle(x)
 estimate_k(x)
+fisher_statistics(x)
 
 #' weights:
 x2 <-  Line(c(0, 0), c(0, 90))
diff --git a/man/vslerp.Rd b/man/vslerp.Rd
index 15173fa..2f08f95 100644
--- a/man/vslerp.Rd
+++ b/man/vslerp.Rd
@@ -17,7 +17,7 @@ Returns the spherical linear interpolation of points between two vectors
 }
 \details{
 A Slerp path is the spherical geometry equivalent of a path along a line
-segment in the plane; a great circle is a spherical geodesic. #'
+segment in the plane; a great circle is a spherical geodesic.
 }
 \note{
 For non-unit vectors the interpolation is not uniform