options(warn = -1)Rolling_Window_Peak_Table
Removing excess warnings from plots
Loading Libraries
library(dplyr)
Attaching package: 'dplyr'The following objects are masked from 'package:stats':
filter, lagThe following objects are masked from 'package:base':
intersect, setdiff, setequal, unionlibrary(lmerTest)Loading required package: lme4Loading required package: Matrix
Attaching package: 'lmerTest'The following object is masked from 'package:lme4':
lmerThe following object is masked from 'package:stats':
steplibrary(tidyverse)── Attaching core tidyverse packages ──────────────────────── tidyverse 2.0.0 ──
✔ forcats 1.0.0 ✔ readr 2.1.5
✔ ggplot2 3.5.1 ✔ stringr 1.5.1
✔ lubridate 1.9.3 ✔ tibble 3.2.1
✔ purrr 1.0.2 ✔ tidyr 1.3.1── Conflicts ────────────────────────────────────────── tidyverse_conflicts() ──
✖ tidyr::expand() masks Matrix::expand()
✖ dplyr::filter() masks stats::filter()
✖ dplyr::lag() masks stats::lag()
✖ tidyr::pack() masks Matrix::pack()
✖ tidyr::unpack() masks Matrix::unpack()
ℹ Use the conflicted package (<http://conflicted.r-lib.org/>) to force all conflicts to become errorslibrary(modelr)
library(purrr)
library(emmeans)Welcome to emmeans.
Caution: You lose important information if you filter this package's results.
See '? untidy'library(gridExtra)
Attaching package: 'gridExtra'
The following object is masked from 'package:dplyr':
combinelibrary(writexl)
library(gt)
library(webshot2)
library(broom.mixed)
library(ggplot2)
library(isotree)
library(tidyr)
library(ggforce)
library(plotrix)
library(pracma)
Attaching package: 'pracma'
The following object is masked from 'package:purrr':
cross
The following object is masked from 'package:lmerTest':
rand
The following objects are masked from 'package:Matrix':
expm, lu, tril, triuLoading the Rdata
load(file="Z:/Isaac/Visual Features/1-5/peak table/nested_df_of_selected.RData")This df is a nested df where it has a full data set per sow, a baseline data set that was used to train a model from -50 ttf to 0 ttf, It has a nest of dfs for each hour after training like from -120 to -49 and -120 to -48 and so on until -120 to 120 for the whole data set. This was done this way to look at in “real time” with the data we have as we are looking to determine the onset of farrowing and that cannot be done with all of the data as we will not have all of the data or know when farrowing actually occurs in real time.
Directory of tables
peaktable_span_75_2_consec table with a span of .75 with a peak detected after a decline of two hours peaktable_span_5_2_consec table with a span of .5 with a peak detected after a decline of two hours peaktable_span_75_1_consec table with a span of .75 with a peak detected after a decline of one hour peaktable_span_5_1_consec table with a span of .5 with a peak detected after a decline of one hour peaktable_span_5_2_bef_2_aft table with a span of .75 with a peak detected after a decline of one hour with a slope ratio with 2 hours before and after the detected peak peaktable_span_75_2_bef_2_aft table with a span of .5 with a peak detected after a decline of one hour with a slope ratio with 2 hours before and after the detected peak peaktable_span_5_2_bef_2_aft_slope_thresh peaktable_span_5_2_bef_2_aft_slope_thresh_1 peaktable_span_35_2_bef_2_aft_slope_thresh_1
Defining Function for peak detection
find_realtime_peak <- function(win, span = 0.75, consistent_hours = 2) {
win <- win %>%
filter(!is.na(anomaly_score)) %>%
arrange(ttf)
if (nrow(win) < 10) return(tibble(
status = "Insufficient data",
peak_ttf = NA_real_,
peak_score = NA_real_
))
# Fit loess on the window's own data
fit <- loess(anomaly_score ~ ttf, data = win, span = span)
ttf_grid <- seq(min(win$ttf), max(win$ttf), length.out = 500)
fitted_vals <- predict(fit, newdata = data.frame(ttf = ttf_grid))
# First derivative
deriv <- diff(fitted_vals) / diff(ttf_grid)
deriv_ttf <- ttf_grid[-1]
# Step size between grid points
step_size <- diff(ttf_grid)[1]
steps_needed <- ceiling(consistent_hours / step_size)
# Zero crossings where slope goes + to -
sign_changes <- which(diff(sign(deriv)) == -2)
if (length(sign_changes) == 0) return(tibble(
status = "No peak yet",
peak_ttf = NA_real_,
peak_score = NA_real_
))
# For each candidate crossing, check that the slope stays
# negative for the next `consistent_hours` hours
confirmed_crossings <- sign_changes[sapply(sign_changes, function(idx) {
end_idx <- min(idx + steps_needed, length(deriv))
all(deriv[(idx + 1):end_idx] < 0)
})]
if (length(confirmed_crossings) == 0) return(tibble(
status = "No peak yet",
peak_ttf = NA_real_,
peak_score = NA_real_
))
candidate_ttfs <- deriv_ttf[confirmed_crossings]
candidate_scores <- fitted_vals[confirmed_crossings + 1]
# Only consider peaks between -50 and 0
valid <- which(candidate_ttfs >= -50 & candidate_ttfs <= 0)
if (length(valid) == 0) return(tibble(
status = "No peak yet",
peak_ttf = NA_real_,
peak_score = NA_real_
))
best <- valid[which.max(candidate_scores[valid])]
best_crossing <- confirmed_crossings[best]
peak_time <- deriv_ttf[best_crossing]
pre_window <- deriv_ttf >= (peak_time - 2) & deriv_ttf < peak_time
post_window <- deriv_ttf > peak_time & deriv_ttf <= (peak_time + 2)
pos_slope <- mean(deriv[pre_window], na.rm = TRUE)
neg_slope <- mean(deriv[post_window], na.rm = TRUE)
slope_ratio <- abs(neg_slope)/pos_slope
tibble(
status = "Peak detected",
peak_ttf = candidate_ttfs[best],
peak_score = candidate_scores[best],
pos_slope = pos_slope,
neg_slope = neg_slope,
slope_ratio = slope_ratio
)
}A table with the definition of what constitutes a peak.
In the table there will be sow number, ttf where peak was detected, ttf peak occurance, fitted value of the peak. To help clean up the table more, this is constrained to the times between end of training data and first instance of farrowing. If a peak was not detected before farrowing, it will be stated. The peak is found after 2 hours with a negative slope.
cutoffs <- -49:120
# Apply across all rolling windows for all sows
realtime_table <- nested_df_of_selected %>%
select(sow, rolling_scored) %>%
mutate(
window_results = map(
rolling_scored,
~ map2_dfr(
.x,
cutoffs,
function(win, cut) {
if (is.null(win) || nrow(win) < 10) {
return(tibble(
window_cutoff = cut,
status = "Insufficient data",
peak_ttf = NA_real_,
peak_score = NA_real_
))
}
result <- find_realtime_peak(win, span = 0.75, consistent_hours = 2)
result %>% mutate(window_cutoff = cut, .before = 1)
}
)
)
) %>%
select(sow, window_results) %>%
unnest(window_results)peaktable_span_75_2_consec
# Get first detected peak per sow (first window where peak is confirmed)
peaktable_span_75_2_consec <- realtime_table %>%
group_by(sow) %>%
arrange(window_cutoff, .by_group = TRUE) %>%
# Find first window where a peak was detected before farrowing
filter(window_cutoff <= 0) %>%
summarise(
first_peak_row = {
detected <- which(status == "Peak detected")
if (length(detected) == 0) {
tibble(
window_cutoff = NA_integer_,
status = "No peak detected before farrowing",
peak_ttf = NA_real_,
peak_score = NA_real_
)
} else {
slice(cur_data()[detected[1], ], 1) %>%
select(window_cutoff, status, peak_ttf, peak_score)
}
},
.groups = "drop"
) %>%
unnest(first_peak_row)
# Display table
peaktable_span_75_2_consec %>%
gt() %>%
tab_header(
title = "First Pre-Farrowing Peak Detected per Sow",
subtitle = "First rolling window (TTF -50 to 0) where loess slope consistently changes + to - for 2 hours with a span of 0.75"
) %>%
fmt_number(
columns = c(peak_ttf, peak_score),
decimals = 2,
rows = !is.na(peak_ttf)
) %>%
cols_label(
sow = "Sow",
window_cutoff = "Window Cutoff (TTF)",
status = "Status",
peak_ttf = "Peak TTF (hrs)",
peak_score = "Peak Anomaly Score"
) %>%
tab_style(
style = cell_fill(color = "lightgreen"),
locations = cells_body(rows = status == "Peak detected")
) %>%
tab_style(
style = cell_fill(color = "salmon"),
locations = cells_body(rows = status == "No peak detected before farrowing")
) %>%
tab_style(
style = cell_text(weight = "bold"),
locations = cells_column_labels()
)| First Pre-Farrowing Peak Detected per Sow | ||||
|---|---|---|---|---|
| First rolling window (TTF -50 to 0) where loess slope consistently changes + to - for 2 hours with a span of 0.75 | ||||
| Sow | Window Cutoff (TTF) | Status | Peak TTF (hrs) | Peak Anomaly Score |
| 2 | -20 | Peak detected | −20.48 | 0.41 |
| 4 | -20 | Peak detected | −24.87 | 0.47 |
| 6 | -46 | Peak detected | −49.69 | 0.43 |
| 8 | -17 | Peak detected | −22.00 | 0.48 |
| 10 | -41 | Peak detected | −41.88 | 0.43 |
| 12 | -24 | Peak detected | −27.86 | 0.47 |
| 14 | -25 | Peak detected | −28.22 | 0.55 |
| 16 | -17 | Peak detected | −20.01 | 0.54 |
| 18 | NA | No peak detected before farrowing | NA | NA |
| 22 | 0 | Peak detected | −6.42 | 0.52 |
| 24 | -11 | Peak detected | −15.87 | 0.46 |
| 26 | -33 | Peak detected | −39.24 | 0.41 |
| 30 | NA | No peak detected before farrowing | NA | NA |
| 32 | -19 | Peak detected | −24.80 | 0.51 |
With this table we see that there were two sows that a peak was not detected
The average time that a peak was detected for the sows where a peak was detected before farrowing is as follows
mean1 <- mean(peaktable_span_75_2_consec$window_cutoff, na.rm=TRUE)
mean1[1] -22.75With a standard error of:
se1 <- std.error(peaktable_span_75_2_consec$window_cutoff, na.rm=TRUE)
se1[1] 3.626763After viewing this, I would like to try a span of 0.5
# Apply across all rolling windows for all sows
realtime_table <- nested_df_of_selected %>%
select(sow, rolling_scored) %>%
mutate(
window_results = map(
rolling_scored,
~ map2_dfr(
.x,
cutoffs,
function(win, cut) {
if (is.null(win) || nrow(win) < 10) {
return(tibble(
window_cutoff = cut,
status = "Insufficient data",
peak_ttf = NA_real_,
peak_score = NA_real_
))
}
result <- find_realtime_peak(win, span = 0.5, consistent_hours = 2)
result %>% mutate(window_cutoff = cut, .before = 1)
}
)
)
) %>%
select(sow, window_results) %>%
unnest(window_results)peaktable_span_5_2_consec
# Get first detected peak per sow (first window where peak is confirmed)
peaktable_span_5_2_consec <- realtime_table %>%
group_by(sow) %>%
arrange(window_cutoff, .by_group = TRUE) %>%
# Find first window where a peak was detected before farrowing
filter(window_cutoff <= 0) %>%
summarise(
first_peak_row = {
detected <- which(status == "Peak detected")
if (length(detected) == 0) {
tibble(
window_cutoff = NA_integer_,
status = "No peak detected before farrowing",
peak_ttf = NA_real_,
peak_score = NA_real_
)
} else {
slice(cur_data()[detected[1], ], 1) %>%
select(window_cutoff, status, peak_ttf, peak_score)
}
},
.groups = "drop"
) %>%
unnest(first_peak_row)
# Display table
peaktable_span_5_2_consec %>%
gt() %>%
tab_header(
title = "First Pre-Farrowing Peak Detected per Sow",
subtitle = "First rolling window (TTF -50 to 0) where loess slope consistently changes + to - for 2 hours with a span of 0.5"
) %>%
fmt_number(
columns = c(peak_ttf, peak_score),
decimals = 2,
rows = !is.na(peak_ttf)
) %>%
cols_label(
sow = "Sow",
window_cutoff = "Window Cutoff (TTF)",
status = "Status",
peak_ttf = "Peak TTF (hrs)",
peak_score = "Peak Anomaly Score"
) %>%
tab_style(
style = cell_fill(color = "lightgreen"),
locations = cells_body(rows = status == "Peak detected")
) %>%
tab_style(
style = cell_fill(color = "salmon"),
locations = cells_body(rows = status == "No peak detected before farrowing")
) %>%
tab_style(
style = cell_text(weight = "bold"),
locations = cells_column_labels()
)| First Pre-Farrowing Peak Detected per Sow | ||||
|---|---|---|---|---|
| First rolling window (TTF -50 to 0) where loess slope consistently changes + to - for 2 hours with a span of 0.5 | ||||
| Sow | Window Cutoff (TTF) | Status | Peak TTF (hrs) | Peak Anomaly Score |
| 2 | -34 | Peak detected | −35.66 | 0.39 |
| 4 | -22 | Peak detected | −27.85 | 0.50 |
| 6 | -15 | Peak detected | −19.83 | 0.52 |
| 8 | -22 | Peak detected | −25.65 | 0.53 |
| 10 | -42 | Peak detected | −49.35 | 0.44 |
| 12 | -26 | Peak detected | −32.85 | 0.50 |
| 14 | -27 | Peak detected | −31.52 | 0.57 |
| 16 | -38 | Peak detected | −41.52 | 0.47 |
| 18 | -31 | Peak detected | −32.99 | 0.43 |
| 22 | -22 | Peak detected | −27.01 | 0.49 |
| 24 | -15 | Peak detected | −20.77 | 0.49 |
| 26 | -39 | Peak detected | −41.57 | 0.44 |
| 30 | -30 | Peak detected | −33.62 | 0.44 |
| 32 | -28 | Peak detected | −29.60 | 0.53 |
With this table we see that there were no sows that a peak was not detected
The average time that a peak was detected for the sows where a peak was detected before farrowing is as follows
mean2 <- mean(peaktable_span_5_2_consec$window_cutoff, na.rm=TRUE)
mean2[1] -27.92857With a standard error of:
se2 <- std.error(peaktable_span_5_2_consec$window_cutoff, na.rm=TRUE)
se2[1] 2.244564After comparing these results, on average the first peak was detected closer to the instance of farrowing with a larger span but with a larger standard error. But with a smaller span, you are able to detect a peak for all of these sows.
I will now look at what changes when I have just the first change in slope after training.
This will be with a change in slope for just a single hour
# Apply across all rolling windows for all sows
realtime_table <- nested_df_of_selected %>%
select(sow, rolling_scored) %>%
mutate(
window_results = map(
rolling_scored,
~ map2_dfr(
.x,
cutoffs,
function(win, cut) {
if (is.null(win) || nrow(win) < 10) {
return(tibble(
window_cutoff = cut,
status = "Insufficient data",
peak_ttf = NA_real_,
peak_score = NA_real_
))
}
result <- find_realtime_peak(win, span = 0.75, consistent_hours = 1)
result %>% mutate(window_cutoff = cut, .before = 1)
}
)
)
) %>%
select(sow, window_results) %>%
unnest(window_results)peaktable_span_75_1_consec
# Get first detected peak per sow (first window where peak is confirmed)
peaktable_span_75_1_consec <- realtime_table %>%
group_by(sow) %>%
arrange(window_cutoff, .by_group = TRUE) %>%
# Find first window where a peak was detected before farrowing
filter(window_cutoff <= 0) %>%
summarise(
first_peak_row = {
detected <- which(status == "Peak detected")
if (length(detected) == 0) {
tibble(
window_cutoff = NA_integer_,
status = "No peak detected before farrowing",
peak_ttf = NA_real_,
peak_score = NA_real_
)
} else {
slice(cur_data()[detected[1], ], 1) %>%
select(window_cutoff, status, peak_ttf, peak_score)
}
},
.groups = "drop"
) %>%
unnest(first_peak_row)
# Display table
peaktable_span_75_1_consec %>%
gt() %>%
tab_header(
title = "First Pre-Farrowing Peak Detected per Sow",
subtitle = "First rolling window (TTF -50 to 0) where loess slope consistently changes + to - for 2 hours with a span of 0.75"
) %>%
fmt_number(
columns = c(peak_ttf, peak_score),
decimals = 2,
rows = !is.na(peak_ttf)
) %>%
cols_label(
sow = "Sow",
window_cutoff = "Window Cutoff (TTF)",
status = "Status",
peak_ttf = "Peak TTF (hrs)",
peak_score = "Peak Anomaly Score"
) %>%
tab_style(
style = cell_fill(color = "lightgreen"),
locations = cells_body(rows = status == "Peak detected")
) %>%
tab_style(
style = cell_fill(color = "salmon"),
locations = cells_body(rows = status == "No peak detected before farrowing")
) %>%
tab_style(
style = cell_text(weight = "bold"),
locations = cells_column_labels()
)| First Pre-Farrowing Peak Detected per Sow | ||||
|---|---|---|---|---|
| First rolling window (TTF -50 to 0) where loess slope consistently changes + to - for 2 hours with a span of 0.75 | ||||
| Sow | Window Cutoff (TTF) | Status | Peak TTF (hrs) | Peak Anomaly Score |
| 2 | -20 | Peak detected | −20.48 | 0.41 |
| 4 | -20 | Peak detected | −24.87 | 0.47 |
| 6 | -46 | Peak detected | −49.69 | 0.43 |
| 8 | -17 | Peak detected | −22.00 | 0.48 |
| 10 | -41 | Peak detected | −41.88 | 0.43 |
| 12 | -24 | Peak detected | −27.86 | 0.47 |
| 14 | -25 | Peak detected | −28.22 | 0.55 |
| 16 | -17 | Peak detected | −20.01 | 0.54 |
| 18 | NA | No peak detected before farrowing | NA | NA |
| 22 | 0 | Peak detected | −6.42 | 0.52 |
| 24 | -11 | Peak detected | −15.87 | 0.46 |
| 26 | -33 | Peak detected | −39.24 | 0.41 |
| 30 | NA | No peak detected before farrowing | NA | NA |
| 32 | -19 | Peak detected | −24.80 | 0.51 |
With this table we see that there were two sows that a peak was not detected
The average time that a peak was detected for the sows where a peak was detected before farrowing is as follows
mean3 <- mean(peaktable_span_75_1_consec$window_cutoff, na.rm=TRUE)
mean3[1] -22.75With a standard error of:
se3 <- std.error(peaktable_span_75_1_consec$window_cutoff, na.rm=TRUE)
se3[1] 3.626763After viewing this, I would like to try a span of 0.5
# Apply across all rolling windows for all sows
realtime_table <- nested_df_of_selected %>%
select(sow, rolling_scored) %>%
mutate(
window_results = map(
rolling_scored,
~ map2_dfr(
.x,
cutoffs,
function(win, cut) {
if (is.null(win) || nrow(win) < 10) {
return(tibble(
window_cutoff = cut,
status = "Insufficient data",
peak_ttf = NA_real_,
peak_score = NA_real_
))
}
result <- find_realtime_peak(win, span = 0.5, consistent_hours = 1)
result %>% mutate(window_cutoff = cut, .before = 1)
}
)
)
) %>%
select(sow, window_results) %>%
unnest(window_results)peaktable_span_5_1_consec
# Get first detected peak per sow (first window where peak is confirmed)
peaktable_span_5_1_consec <- realtime_table %>%
group_by(sow) %>%
arrange(window_cutoff, .by_group = TRUE) %>%
# Find first window where a peak was detected before farrowing
filter(window_cutoff <= 0) %>%
summarise(
first_peak_row = {
detected <- which(status == "Peak detected")
if (length(detected) == 0) {
tibble(
window_cutoff = NA_integer_,
status = "No peak detected before farrowing",
peak_ttf = NA_real_,
peak_score = NA_real_
)
} else {
slice(cur_data()[detected[1], ], 1) %>%
select(window_cutoff, status, peak_ttf, peak_score)
}
},
.groups = "drop"
) %>%
unnest(first_peak_row)
# Display table
peaktable_span_5_1_consec %>%
gt() %>%
tab_header(
title = "First Pre-Farrowing Peak Detected per Sow",
subtitle = "First rolling window (TTF -50 to 0) where loess slope consistently changes + to - for 2 hours with a span of 0.5"
) %>%
fmt_number(
columns = c(peak_ttf, peak_score),
decimals = 2,
rows = !is.na(peak_ttf)
) %>%
cols_label(
sow = "Sow",
window_cutoff = "Window Cutoff (TTF)",
status = "Status",
peak_ttf = "Peak TTF (hrs)",
peak_score = "Peak Anomaly Score"
) %>%
tab_style(
style = cell_fill(color = "lightgreen"),
locations = cells_body(rows = status == "Peak detected")
) %>%
tab_style(
style = cell_fill(color = "salmon"),
locations = cells_body(rows = status == "No peak detected before farrowing")
) %>%
tab_style(
style = cell_text(weight = "bold"),
locations = cells_column_labels()
)| First Pre-Farrowing Peak Detected per Sow | ||||
|---|---|---|---|---|
| First rolling window (TTF -50 to 0) where loess slope consistently changes + to - for 2 hours with a span of 0.5 | ||||
| Sow | Window Cutoff (TTF) | Status | Peak TTF (hrs) | Peak Anomaly Score |
| 2 | -34 | Peak detected | −35.66 | 0.39 |
| 4 | -22 | Peak detected | −27.85 | 0.50 |
| 6 | -15 | Peak detected | −19.83 | 0.52 |
| 8 | -22 | Peak detected | −25.65 | 0.53 |
| 10 | -42 | Peak detected | −49.35 | 0.44 |
| 12 | -26 | Peak detected | −32.85 | 0.50 |
| 14 | -27 | Peak detected | −31.52 | 0.57 |
| 16 | -38 | Peak detected | −41.52 | 0.47 |
| 18 | -31 | Peak detected | −32.99 | 0.43 |
| 22 | -22 | Peak detected | −27.01 | 0.49 |
| 24 | -15 | Peak detected | −20.77 | 0.49 |
| 26 | -39 | Peak detected | −41.57 | 0.44 |
| 30 | -30 | Peak detected | −33.62 | 0.44 |
| 32 | -28 | Peak detected | −29.60 | 0.53 |
With this table we see that there were no sows that a peak was not detected
The average time that a peak was detected for the sows where a peak was detected before farrowing is as follows
mean4 <- mean(peaktable_span_5_1_consec$window_cutoff, na.rm=TRUE)
mean4[1] -27.92857With a standard error of:
se4 <-std.error(peaktable_span_5_1_consec$window_cutoff, na.rm=TRUE)
se4[1] 2.244564After comparing the results of 2 hours of consecutive change in slope versus a single change, there seems to be little to no difference in results when loooking at both a span of 0.75 and 0.5.
I will now look at a percentage of change.
For this I will look at the current values of change of what percentage of change it is from the 2 hours leading up to the detected peak with the 2 hours after the peak and see what the ratio of the slopes are to determine if there should be a percentage of change in slope to help predict farrowing.
# Apply across all rolling windows for all sows
realtime_table <- nested_df_of_selected %>%
select(sow, rolling_scored) %>%
mutate(
window_results = map(
rolling_scored,
~ map2_dfr(
.x,
cutoffs,
function(win, cut) {
if (is.null(win) || nrow(win) < 10) {
return(tibble(
window_cutoff = cut,
status = "Insufficient data",
peak_ttf = NA_real_,
peak_score = NA_real_,
pos_slope = NA_real_,
neg_slope = NA_real_,
slope_ratio = NA_real_
))
}
result <- find_realtime_peak(win, span = 0.5, consistent_hours = 1)
result %>% mutate(window_cutoff = cut, .before = 1)
}
)
)
) %>%
select(sow, window_results) %>%
unnest(window_results)peaktable_span_5_2_bef_2_aft
# Get first detected peak per sow (first window where peak is confirmed)
peaktable_span_5_2_bef_2_aft <- realtime_table %>%
group_by(sow) %>%
arrange(window_cutoff, .by_group = TRUE) %>%
# Find first window where a peak was detected before farrowing
filter(window_cutoff <= 0) %>%
summarise(
first_peak_row = {
detected <- which(status == "Peak detected")
if (length(detected) == 0) {
tibble(
window_cutoff = NA_integer_,
status = "No peak detected before farrowing",
peak_ttf = NA_real_,
peak_score = NA_real_,
pos_slope = NA_real_,
neg_slope = NA_real_,
slope_ratio = NA_real_
)
} else {
slice(cur_data()[detected[1], ], 1) %>%
select(window_cutoff, status, peak_ttf, peak_score, pos_slope, neg_slope, slope_ratio)
}
},
.groups = "drop"
) %>%
unnest(first_peak_row)
# Display table
peaktable_span_5_2_bef_2_aft %>%
gt() %>%
tab_header(
title = "First Pre-Farrowing Peak Detected per Sow",
subtitle = "First rolling window (TTF -50 to 0) where loess slope consistently changes + to - for 2 hours with a span of 0.5"
) %>%
fmt_number(
columns = c(peak_ttf, peak_score),
decimals = 2,
rows = !is.na(peak_ttf)
) %>%
cols_label(
sow = "Sow",
window_cutoff = "Window Cutoff (TTF)",
status = "Status",
peak_ttf = "Peak TTF (hrs)",
peak_score = "Peak Anomaly Score",
pos_slope = "Slope before peak",
neg_slope = "Slope after peak",
slope_ratio = "Slope ratio ((|Slope after|)/(Slope before))"
) %>%
tab_style(
style = cell_fill(color = "lightgreen"),
locations = cells_body(rows = status == "Peak detected")
) %>%
tab_style(
style = cell_fill(color = "salmon"),
locations = cells_body(rows = status == "No peak detected before farrowing")
) %>%
tab_style(
style = cell_text(weight = "bold"),
locations = cells_column_labels()
)| First Pre-Farrowing Peak Detected per Sow | |||||||
|---|---|---|---|---|---|---|---|
| First rolling window (TTF -50 to 0) where loess slope consistently changes + to - for 2 hours with a span of 0.5 | |||||||
| Sow | Window Cutoff (TTF) | Status | Peak TTF (hrs) | Peak Anomaly Score | Slope before peak | Slope after peak | Slope ratio ((|Slope after|)/(Slope before)) |
| 2 | -34 | Peak detected | −35.66 | 0.39 | 0.0006772258 | -2.139994e-04 | 0.3159942 |
| 4 | -22 | Peak detected | −27.85 | 0.50 | 0.0006189332 | -8.022101e-04 | 1.2961173 |
| 6 | -15 | Peak detected | −19.83 | 0.52 | 0.0012612155 | -9.230702e-04 | 0.7318894 |
| 8 | -22 | Peak detected | −25.65 | 0.53 | 0.0012546587 | -7.459551e-04 | 0.5945483 |
| 10 | -42 | Peak detected | −49.35 | 0.44 | 0.0001861532 | -3.562436e-04 | 1.9137114 |
| 12 | -26 | Peak detected | −32.85 | 0.50 | 0.0006345351 | -7.624947e-04 | 1.2016588 |
| 14 | -27 | Peak detected | −31.52 | 0.57 | 0.0008730724 | -1.112438e-03 | 1.2741644 |
| 16 | -38 | Peak detected | −41.52 | 0.47 | 0.0008520580 | -9.995764e-04 | 1.1731318 |
| 18 | -31 | Peak detected | −32.99 | 0.43 | 0.0003022456 | -7.681721e-05 | 0.2541549 |
| 22 | -22 | Peak detected | −27.01 | 0.49 | 0.0010512904 | -8.719002e-04 | 0.8293619 |
| 24 | -15 | Peak detected | −20.77 | 0.49 | 0.0008971641 | -1.114635e-03 | 1.2423985 |
| 26 | -39 | Peak detected | −41.57 | 0.44 | 0.0018694529 | -1.342590e-03 | 0.7181726 |
| 30 | -30 | Peak detected | −33.62 | 0.44 | 0.0007514508 | -4.402784e-04 | 0.5859044 |
| 32 | -28 | Peak detected | −29.60 | 0.53 | 0.0002673115 | -1.070911e-04 | 0.4006230 |
The average slope ratio is:
mean5 <- mean(peaktable_span_5_2_bef_2_aft$slope_ratio,na.rm=TRUE)
mean5[1] 0.8951308With a standard error of:
se5 <- std.error(peaktable_span_5_2_bef_2_aft$slope_ratio,na.rm=TRUE)
se5[1] 0.1256379The summary stats for this is:
summary(peaktable_span_5_2_bef_2_aft$slope_ratio) Min. 1st Qu. Median Mean 3rd Qu. Max.
0.2542 0.5881 0.7806 0.8951 1.2322 1.9137 Now for the span of 0.75
# Apply across all rolling windows for all sows
realtime_table <- nested_df_of_selected %>%
select(sow, rolling_scored) %>%
mutate(
window_results = map(
rolling_scored,
~ map2_dfr(
.x,
cutoffs,
function(win, cut) {
if (is.null(win) || nrow(win) < 10) {
return(tibble(
window_cutoff = cut,
status = "Insufficient data",
peak_ttf = NA_real_,
peak_score = NA_real_,
pos_slope = NA_real_,
neg_slope = NA_real_,
slope_ratio = NA_real_
))
}
result <- find_realtime_peak(win, span = 0.75, consistent_hours = 1)
result %>% mutate(window_cutoff = cut, .before = 1)
}
)
)
) %>%
select(sow, window_results) %>%
unnest(window_results)peaktable_span_75_2_bef_2_aft
# Get first detected peak per sow (first window where peak is confirmed)
peaktable_span_75_2_bef_2_aft <- realtime_table %>%
group_by(sow) %>%
arrange(window_cutoff, .by_group = TRUE) %>%
# Find first window where a peak was detected before farrowing
filter(window_cutoff <= 0) %>%
summarise(
first_peak_row = {
detected <- which(status == "Peak detected")
if (length(detected) == 0) {
tibble(
window_cutoff = NA_integer_,
status = "No peak detected before farrowing",
peak_ttf = NA_real_,
peak_score = NA_real_,
pos_slope = NA_real_,
neg_slope = NA_real_,
slope_ratio = NA_real_
)
} else {
slice(cur_data()[detected[1], ], 1) %>%
select(window_cutoff, status, peak_ttf, peak_score, pos_slope, neg_slope, slope_ratio)
}
},
.groups = "drop"
) %>%
unnest(first_peak_row)
# Display table
peaktable_span_75_2_bef_2_aft %>%
gt() %>%
tab_header(
title = "First Pre-Farrowing Peak Detected per Sow",
subtitle = "First rolling window (TTF -50 to 0) where loess slope consistently changes + to - for 2 hours with a span of 0.75"
) %>%
fmt_number(
columns = c(peak_ttf, peak_score),
decimals = 2,
rows = !is.na(peak_ttf)
) %>%
cols_label(
sow = "Sow",
window_cutoff = "Window Cutoff (TTF)",
status = "Status",
peak_ttf = "Peak TTF (hrs)",
peak_score = "Peak Anomaly Score",
pos_slope = "Slope before peak",
neg_slope = "Slope after peak",
slope_ratio = "Slope ratio ((|Slope after|)/(Slope before))"
) %>%
tab_style(
style = cell_fill(color = "lightgreen"),
locations = cells_body(rows = status == "Peak detected")
) %>%
tab_style(
style = cell_fill(color = "salmon"),
locations = cells_body(rows = status == "No peak detected before farrowing")
) %>%
tab_style(
style = cell_text(weight = "bold"),
locations = cells_column_labels()
)| First Pre-Farrowing Peak Detected per Sow | |||||||
|---|---|---|---|---|---|---|---|
| First rolling window (TTF -50 to 0) where loess slope consistently changes + to - for 2 hours with a span of 0.75 | |||||||
| Sow | Window Cutoff (TTF) | Status | Peak TTF (hrs) | Peak Anomaly Score | Slope before peak | Slope after peak | Slope ratio ((|Slope after|)/(Slope before)) |
| 2 | -20 | Peak detected | −20.48 | 0.41 | 1.104475e-04 | -1.144903e-05 | 0.1036605 |
| 4 | -20 | Peak detected | −24.87 | 0.47 | 1.050936e-04 | -7.662491e-05 | 0.7291110 |
| 6 | -46 | Peak detected | −49.69 | 0.43 | 2.146657e-04 | -1.567483e-04 | 0.7301970 |
| 8 | -17 | Peak detected | −22.00 | 0.48 | 1.729462e-04 | -1.141740e-04 | 0.6601705 |
| 10 | -41 | Peak detected | −41.88 | 0.43 | 8.095945e-05 | -2.229411e-05 | 0.2753738 |
| 12 | -24 | Peak detected | −27.86 | 0.47 | 1.203650e-04 | -7.824407e-05 | 0.6500566 |
| 14 | -25 | Peak detected | −28.22 | 0.55 | 3.240836e-04 | -2.342701e-04 | 0.7228695 |
| 16 | -17 | Peak detected | −20.01 | 0.54 | 2.579134e-04 | -2.262678e-04 | 0.8773016 |
| 18 | NA | No peak detected before farrowing | NA | NA | NA | NA | NA |
| 22 | 0 | Peak detected | −6.42 | 0.52 | 1.400409e-04 | -1.278893e-04 | 0.9132282 |
| 24 | -11 | Peak detected | −15.87 | 0.46 | 1.351770e-04 | -1.223318e-04 | 0.9049753 |
| 26 | -33 | Peak detected | −39.24 | 0.41 | 4.567115e-04 | -3.779709e-04 | 0.8275921 |
| 30 | NA | No peak detected before farrowing | NA | NA | NA | NA | NA |
| 32 | -19 | Peak detected | −24.80 | 0.51 | 1.002595e-04 | -6.853695e-05 | 0.6835958 |
The average slope ratio is:
mean6 <- mean(peaktable_span_75_2_bef_2_aft$slope_ratio,na.rm=TRUE)
mean6[1] 0.6731777With a standard error of:
se6 <- std.error(peaktable_span_75_2_bef_2_aft$slope_ratio,na.rm=TRUE)
se6[1] 0.07119776Now I will looking at using a threshold from the average slope ratio with the 0.5 span (0.8951308) as a threshold for a peak for the span of 0.5 to see if that helps
redefining function for adding a slope threshold
find_realtime_peak <- function(win, span = 0.75, consistent_hours = 2, min_slope_ratio = 0.8951308) {
win <- win %>%
filter(!is.na(anomaly_score)) %>%
arrange(ttf)
if (nrow(win) < 10) return(tibble(
status = "Insufficient data",
peak_ttf = NA_real_,
peak_score = NA_real_,
pos_slope = NA_real_,
neg_slope = NA_real_,
slope_ratio = NA_real_
))
# Fit loess on the window's own data
fit <- loess(anomaly_score ~ ttf, data = win, span = span)
ttf_grid <- seq(min(win$ttf), max(win$ttf), length.out = 500)
fitted_vals <- predict(fit, newdata = data.frame(ttf = ttf_grid))
# First derivative
deriv <- diff(fitted_vals) / diff(ttf_grid)
deriv_ttf <- ttf_grid[-1]
# Step size between grid points
step_size <- diff(ttf_grid)[1]
steps_needed <- ceiling(consistent_hours / step_size)
# Zero crossings where slope goes + to -
sign_changes <- which(diff(sign(deriv)) == -2)
if (length(sign_changes) == 0) return(tibble(
status = "No peak yet",
peak_ttf = NA_real_,
peak_score = NA_real_,
pos_slope = NA_real_,
neg_slope = NA_real_,
slope_ratio = NA_real_
))
# For each candidate crossing, check that the slope stays
# negative for the next `consistent_hours` hours
confirmed_crossings <- sign_changes[sapply(sign_changes, function(idx) {
end_idx <- min(idx + steps_needed, length(deriv))
all(deriv[(idx + 1):end_idx] < 0)
})]
if (length(confirmed_crossings) == 0) return(tibble(
status = "No peak yet",
peak_ttf = NA_real_,
peak_score = NA_real_,
pos_slope = NA_real_,
neg_slope = NA_real_,
slope_ratio = NA_real_
))
candidate_ttfs <- deriv_ttf[confirmed_crossings]
candidate_scores <- fitted_vals[confirmed_crossings + 1]
# Only consider peaks between -50 and 0
valid <- which(candidate_ttfs >= -50 & candidate_ttfs <= 0)
if (length(valid) == 0) return(tibble(
status = "No peak yet",
peak_ttf = NA_real_,
peak_score = NA_real_,
pos_slope = NA_real_,
neg_slope = NA_real_,
slope_ratio = NA_real_
))
# For each valid peak, compute slope ratio and filter by threshold
valid_with_ratio <- sapply(valid, function(v) {
best_crossing <- confirmed_crossings[v]
peak_time <- deriv_ttf[best_crossing]
pre_window <- deriv_ttf >= (peak_time - 2) & deriv_ttf < peak_time
post_window <- deriv_ttf > peak_time & deriv_ttf <= (peak_time + 2)
pos_slope <- mean(deriv[pre_window], na.rm = TRUE)
neg_slope <- mean(deriv[post_window], na.rm = TRUE)
slope_ratio <- abs(neg_slope) / pos_slope
# Return TRUE if slope ratio meets threshold
slope_ratio >= min_slope_ratio
})
valid_peaks <- valid[valid_with_ratio]
if (length(valid_peaks) == 0) return(tibble(
status = "No peak yet",
peak_ttf = NA_real_,
peak_score = NA_real_,
pos_slope = NA_real_,
neg_slope = NA_real_,
slope_ratio = NA_real_
))
# Take the highest scoring peak that passes the threshold
best <- valid_peaks[which.max(candidate_scores[valid_peaks])]
best_crossing <- confirmed_crossings[best]
peak_time <- deriv_ttf[best_crossing]
pre_window <- deriv_ttf >= (peak_time - 2) & deriv_ttf < peak_time
post_window <- deriv_ttf > peak_time & deriv_ttf <= (peak_time + 2)
pos_slope <- mean(deriv[pre_window], na.rm = TRUE)
neg_slope <- mean(deriv[post_window], na.rm = TRUE)
slope_ratio <- abs(neg_slope) / pos_slope
tibble(
status = "Peak detected",
peak_ttf = candidate_ttfs[best],
peak_score = candidate_scores[best],
pos_slope = pos_slope,
neg_slope = neg_slope,
slope_ratio = slope_ratio
)
}realtime_table <- nested_df_of_selected %>%
select(sow, rolling_scored) %>%
mutate(
window_results = map(
rolling_scored,
~ map2_dfr(
.x,
cutoffs,
function(win, cut) {
if (is.null(win) || nrow(win) < 10) {
return(tibble(
window_cutoff = cut,
status = "Insufficient data",
peak_ttf = NA_real_,
peak_score = NA_real_,
pos_slope = NA_real_,
neg_slope = NA_real_,
slope_ratio = NA_real_
))
}
result <- find_realtime_peak(win, span = 0.5, consistent_hours = 1, min_slope_ratio = 0.8951308)
result %>% mutate(window_cutoff = cut, .before = 1)
}
)
)
) %>%
select(sow, window_results) %>%
unnest(window_results)peaktable_span_5_2_bef_2_aft_slope_thresh
# Get first detected peak per sow (first window where peak is confirmed)
peaktable_span_5_2_bef_2_aft_slope_thresh <- realtime_table %>%
group_by(sow) %>%
arrange(window_cutoff, .by_group = TRUE) %>%
# Find first window where a peak was detected before farrowing
filter(window_cutoff <= 0) %>%
summarise(
first_peak_row = {
detected <- which(status == "Peak detected")
if (length(detected) == 0) {
tibble(
window_cutoff = NA_integer_,
status = "No peak detected before farrowing",
peak_ttf = NA_real_,
peak_score = NA_real_,
pos_slope = NA_real_,
neg_slope = NA_real_,
slope_ratio = NA_real_
)
} else {
slice(cur_data()[detected[1], ], 1) %>%
select(window_cutoff, status, peak_ttf, peak_score, pos_slope, neg_slope, slope_ratio)
}
},
.groups = "drop"
) %>%
unnest(first_peak_row)
# Display table
peaktable_span_5_2_bef_2_aft_slope_thresh %>%
gt() %>%
tab_header(
title = "First Pre-Farrowing Peak Detected per Sow",
subtitle = "First rolling window (TTF -50 to 0) where loess slope consistently changes + to - for 2 hours with a span of 0.5 with a slope ratio threshold of 0.8951308"
) %>%
fmt_number(
columns = c(peak_ttf, peak_score),
decimals = 2,
rows = !is.na(peak_ttf)
) %>%
cols_label(
sow = "Sow",
window_cutoff = "Window Cutoff (TTF)",
status = "Status",
peak_ttf = "Peak TTF (hrs)",
peak_score = "Peak Anomaly Score",
pos_slope = "Slope before peak",
neg_slope = "Slope after peak",
slope_ratio = "Slope ratio ((|Slope after|)/(Slope before))"
) %>%
tab_style(
style = cell_fill(color = "lightgreen"),
locations = cells_body(rows = status == "Peak detected")
) %>%
tab_style(
style = cell_fill(color = "salmon"),
locations = cells_body(rows = status == "No peak detected before farrowing")
) %>%
tab_style(
style = cell_text(weight = "bold"),
locations = cells_column_labels()
)| First Pre-Farrowing Peak Detected per Sow | |||||||
|---|---|---|---|---|---|---|---|
| First rolling window (TTF -50 to 0) where loess slope consistently changes + to - for 2 hours with a span of 0.5 with a slope ratio threshold of 0.8951308 | |||||||
| Sow | Window Cutoff (TTF) | Status | Peak TTF (hrs) | Peak Anomaly Score | Slope before peak | Slope after peak | Slope ratio ((|Slope after|)/(Slope before)) |
| 2 | -33 | Peak detected | −37.57 | 0.39 | 0.0005189581 | -0.0006835839 | 1.3172238 |
| 4 | -22 | Peak detected | −27.85 | 0.50 | 0.0006189332 | -0.0008022101 | 1.2961173 |
| 6 | -14 | Peak detected | −19.43 | 0.52 | 0.0010945440 | -0.0010699308 | 0.9775128 |
| 8 | -21 | Peak detected | −27.80 | 0.52 | 0.0009078704 | -0.0010553770 | 1.1624754 |
| 10 | -42 | Peak detected | −49.35 | 0.44 | 0.0001861532 | -0.0003562436 | 1.9137114 |
| 12 | -26 | Peak detected | −32.85 | 0.50 | 0.0006345351 | -0.0007624947 | 1.2016588 |
| 14 | -27 | Peak detected | −31.52 | 0.57 | 0.0008730724 | -0.0011124378 | 1.2741644 |
| 16 | -38 | Peak detected | −41.52 | 0.47 | 0.0008520580 | -0.0009995764 | 1.1731318 |
| 18 | -30 | Peak detected | −37.26 | 0.42 | 0.0003411042 | -0.0004475044 | 1.3119287 |
| 22 | -21 | Peak detected | −27.55 | 0.49 | 0.0008127364 | -0.0008853570 | 1.0893531 |
| 24 | -15 | Peak detected | −20.77 | 0.49 | 0.0008971641 | -0.0011146353 | 1.2423985 |
| 26 | -37 | Peak detected | −42.49 | 0.44 | 0.0011826055 | -0.0012592069 | 1.0647734 |
| 30 | -4 | Peak detected | −14.78 | 0.64 | 0.0007314642 | -0.0007306034 | 0.9988232 |
| 32 | -27 | Peak detected | −33.44 | 0.53 | 0.0004293402 | -0.0005167597 | 1.2036136 |
The average slope ratio is:
mean7 <- mean(peaktable_span_5_2_bef_2_aft_slope_thresh$window_cutoff,na.rm=TRUE)
mean7[1] -25.5With a standard error of:
se7 <- std.error(peaktable_span_5_2_bef_2_aft_slope_thresh$window_cutoff,na.rm=TRUE)
se7[1] 2.773006Looking at this, we can see that with adding a threshold for the slope ratio that it brings the peak detection closer to farrowing.
I will try using a slope ratio threshold of 1 to see what will come of it
realtime_table <- nested_df_of_selected %>%
select(sow, rolling_scored) %>%
mutate(
window_results = map(
rolling_scored,
~ map2_dfr(
.x,
cutoffs,
function(win, cut) {
if (is.null(win) || nrow(win) < 10) {
return(tibble(
window_cutoff = cut,
status = "Insufficient data",
peak_ttf = NA_real_,
peak_score = NA_real_,
pos_slope = NA_real_,
neg_slope = NA_real_,
slope_ratio = NA_real_
))
}
result <- find_realtime_peak(win, span = 0.5, consistent_hours = 1, min_slope_ratio = 1)
result %>% mutate(window_cutoff = cut, .before = 1)
}
)
)
) %>%
select(sow, window_results) %>%
unnest(window_results)peaktable_span_5_2_bef_2_aft_slope_thresh_1
# Get first detected peak per sow (first window where peak is confirmed)
peaktable_span_5_2_bef_2_aft_slope_thresh_1 <- realtime_table %>%
group_by(sow) %>%
arrange(window_cutoff, .by_group = TRUE) %>%
# Find first window where a peak was detected before farrowing
filter(window_cutoff <= 0) %>%
summarise(
first_peak_row = {
detected <- which(status == "Peak detected")
if (length(detected) == 0) {
tibble(
window_cutoff = NA_integer_,
status = "No peak detected before farrowing",
peak_ttf = NA_real_,
peak_score = NA_real_,
pos_slope = NA_real_,
neg_slope = NA_real_,
slope_ratio = NA_real_
)
} else {
slice(cur_data()[detected[1], ], 1) %>%
select(window_cutoff, status, peak_ttf, peak_score, pos_slope, neg_slope, slope_ratio)
}
},
.groups = "drop"
) %>%
unnest(first_peak_row)
# Display table
peaktable_span_5_2_bef_2_aft_slope_thresh_1 %>%
gt() %>%
tab_header(
title = "First Pre-Farrowing Peak Detected per Sow",
subtitle = "First rolling window (TTF -50 to 0) where loess slope consistently changes + to - for 2 hours with a span of 0.5 with a slope ratio threshold of 1"
) %>%
fmt_number(
columns = c(peak_ttf, peak_score),
decimals = 2,
rows = !is.na(peak_ttf)
) %>%
cols_label(
sow = "Sow",
window_cutoff = "Window Cutoff (TTF)",
status = "Status",
peak_ttf = "Peak TTF (hrs)",
peak_score = "Peak Anomaly Score",
pos_slope = "Slope before peak",
neg_slope = "Slope after peak",
slope_ratio = "Slope ratio ((|Slope after|)/(Slope before))"
) %>%
tab_style(
style = cell_fill(color = "lightgreen"),
locations = cells_body(rows = status == "Peak detected")
) %>%
tab_style(
style = cell_fill(color = "salmon"),
locations = cells_body(rows = status == "No peak detected before farrowing")
) %>%
tab_style(
style = cell_text(weight = "bold"),
locations = cells_column_labels()
)| First Pre-Farrowing Peak Detected per Sow | |||||||
|---|---|---|---|---|---|---|---|
| First rolling window (TTF -50 to 0) where loess slope consistently changes + to - for 2 hours with a span of 0.5 with a slope ratio threshold of 1 | |||||||
| Sow | Window Cutoff (TTF) | Status | Peak TTF (hrs) | Peak Anomaly Score | Slope before peak | Slope after peak | Slope ratio ((|Slope after|)/(Slope before)) |
| 2 | -33 | Peak detected | −37.57 | 0.39 | 0.0005189581 | -0.0006835839 | 1.317224 |
| 4 | -22 | Peak detected | −27.85 | 0.50 | 0.0006189332 | -0.0008022101 | 1.296117 |
| 6 | -13 | Peak detected | −22.16 | 0.51 | 0.0005374293 | -0.0007438780 | 1.384141 |
| 8 | -21 | Peak detected | −27.80 | 0.52 | 0.0009078704 | -0.0010553770 | 1.162475 |
| 10 | -42 | Peak detected | −49.35 | 0.44 | 0.0001861532 | -0.0003562436 | 1.913711 |
| 12 | -26 | Peak detected | −32.85 | 0.50 | 0.0006345351 | -0.0007624947 | 1.201659 |
| 14 | -27 | Peak detected | −31.52 | 0.57 | 0.0008730724 | -0.0011124378 | 1.274164 |
| 16 | -38 | Peak detected | −41.52 | 0.47 | 0.0008520580 | -0.0009995764 | 1.173132 |
| 18 | -30 | Peak detected | −37.26 | 0.42 | 0.0003411042 | -0.0004475044 | 1.311929 |
| 22 | -21 | Peak detected | −27.55 | 0.49 | 0.0008127364 | -0.0008853570 | 1.089353 |
| 24 | -15 | Peak detected | −20.77 | 0.49 | 0.0008971641 | -0.0011146353 | 1.242398 |
| 26 | -37 | Peak detected | −42.49 | 0.44 | 0.0011826055 | -0.0012592069 | 1.064773 |
| 30 | NA | No peak detected before farrowing | NA | NA | NA | NA | NA |
| 32 | -27 | Peak detected | −33.44 | 0.53 | 0.0004293402 | -0.0005167597 | 1.203614 |
The average slope ratio is:
mean8 <- mean(peaktable_span_5_2_bef_2_aft_slope_thresh_1$window_cutoff,na.rm=TRUE)
mean8[1] -27.07692With a standard error of:
se8 <- std.error(peaktable_span_5_2_bef_2_aft_slope_thresh_1$window_cutoff,na.rm=TRUE)
se8[1] 2.440212In changing the slope ratio threshold, there was one sow that was not able detect a peak before farrowing
I will now look at what happens if I leave it the same but decrease the span to 0.35
realtime_table <- nested_df_of_selected %>%
select(sow, rolling_scored) %>%
mutate(
window_results = map(
rolling_scored,
~ map2_dfr(
.x,
cutoffs,
function(win, cut) {
if (is.null(win) || nrow(win) < 10) {
return(tibble(
window_cutoff = cut,
status = "Insufficient data",
peak_ttf = NA_real_,
peak_score = NA_real_,
pos_slope = NA_real_,
neg_slope = NA_real_,
slope_ratio = NA_real_
))
}
result <- find_realtime_peak(win, span = 0.35, consistent_hours = 2, min_slope_ratio = 1)
result %>% mutate(window_cutoff = cut, .before = 1)
}
)
)
) %>%
select(sow, window_results) %>%
unnest(window_results)peaktable_span_35_2_bef_2_aft_slope_thresh_1
# Get first detected peak per sow (first window where peak is confirmed)
peaktable_span_35_2_bef_2_aft_slope_thresh_1 <- realtime_table %>%
group_by(sow) %>%
arrange(window_cutoff, .by_group = TRUE) %>%
# Find first window where a peak was detected before farrowing
filter(window_cutoff <= 0) %>%
summarise(
first_peak_row = {
detected <- which(status == "Peak detected")
if (length(detected) == 0) {
tibble(
window_cutoff = NA_integer_,
status = "No peak detected before farrowing",
peak_ttf = NA_real_,
peak_score = NA_real_,
pos_slope = NA_real_,
neg_slope = NA_real_,
slope_ratio = NA_real_
)
} else {
slice(cur_data()[detected[1], ], 1) %>%
select(window_cutoff, status, peak_ttf, peak_score, pos_slope, neg_slope, slope_ratio)
}
},
.groups = "drop"
) %>%
unnest(first_peak_row)
# Display table
peaktable_span_35_2_bef_2_aft_slope_thresh_1 %>%
gt() %>%
tab_header(
title = "First Pre-Farrowing Peak Detected per Sow",
subtitle = "First rolling window (TTF -50 to 0) where loess slope consistently changes + to - for 2 hours with a span of 0.35 with a slope ratio threshold of 1"
) %>%
fmt_number(
columns = c(peak_ttf, peak_score),
decimals = 2,
rows = !is.na(peak_ttf)
) %>%
cols_label(
sow = "Sow",
window_cutoff = "Window Cutoff (TTF)",
status = "Status",
peak_ttf = "Peak TTF (hrs)",
peak_score = "Peak Anomaly Score",
pos_slope = "Slope before peak",
neg_slope = "Slope after peak",
slope_ratio = "Slope ratio ((|Slope after|)/(Slope before))"
) %>%
tab_style(
style = cell_fill(color = "lightgreen"),
locations = cells_body(rows = status == "Peak detected")
) %>%
tab_style(
style = cell_fill(color = "salmon"),
locations = cells_body(rows = status == "No peak detected before farrowing")
) %>%
tab_style(
style = cell_text(weight = "bold"),
locations = cells_column_labels()
)| First Pre-Farrowing Peak Detected per Sow | |||||||
|---|---|---|---|---|---|---|---|
| First rolling window (TTF -50 to 0) where loess slope consistently changes + to - for 2 hours with a span of 0.35 with a slope ratio threshold of 1 | |||||||
| Sow | Window Cutoff (TTF) | Status | Peak TTF (hrs) | Peak Anomaly Score | Slope before peak | Slope after peak | Slope ratio ((|Slope after|)/(Slope before)) |
| 2 | -44 | Peak detected | −47.90 | 0.35 | 0.0001992083 | -0.0008900545 | 4.467959 |
| 4 | -18 | Peak detected | −31.07 | 0.53 | 0.0027603620 | -0.0034919395 | 1.265030 |
| 6 | -17 | Peak detected | −24.36 | 0.55 | 0.0027341115 | -0.0029047010 | 1.062393 |
| 8 | -23 | Peak detected | −30.91 | 0.56 | 0.0023902401 | -0.0029820883 | 1.247610 |
| 10 | -1 | Peak detected | −20.36 | 0.56 | 0.0028221869 | -0.0031482878 | 1.115549 |
| 12 | -27 | Peak detected | −34.31 | 0.53 | 0.0020321423 | -0.0024432422 | 1.202299 |
| 14 | -24 | Peak detected | −33.36 | 0.58 | 0.0037125600 | -0.0044258562 | 1.192131 |
| 16 | -33 | Peak detected | −43.10 | 0.47 | 0.0011093979 | -0.0023863348 | 2.151018 |
| 18 | -34 | Peak detected | −40.28 | 0.43 | 0.0017909084 | -0.0018587694 | 1.037892 |
| 22 | -12 | Peak detected | −30.99 | 0.52 | 0.0016482444 | -0.0037292226 | 2.262542 |
| 24 | -16 | Peak detected | −23.52 | 0.53 | 0.0022347084 | -0.0026046539 | 1.165545 |
| 26 | -41 | Peak detected | −45.26 | 0.45 | 0.0042152765 | -0.0047297776 | 1.122056 |
| 30 | -31 | Peak detected | −37.79 | 0.45 | 0.0017834321 | -0.0020164562 | 1.130660 |
| 32 | -16 | Peak detected | −35.69 | 0.55 | 0.0017286020 | -0.0021647178 | 1.252294 |
The average slope ratio is:
mean9 <- mean(peaktable_span_35_2_bef_2_aft_slope_thresh_1$window_cutoff,na.rm=TRUE)
mean9[1] -24.07143With a standard error of:
se9 <- std.error(peaktable_span_35_2_bef_2_aft_slope_thresh_1$window_cutoff,na.rm=TRUE)
se9[1] 3.157869Table with all average peak detection window cutoff with standard error
peak_detection_table <- data.frame(
table = c('peaktable_span_75_2_consec','peaktable_span_5_2_consec','peaktable_span_75_1_consec','peaktable_span_5_1_consec','peaktable_span_5_2_bef_2_aft_slope_thresh','peaktable_span_5_2_bef_2_aft_slope_thresh_1','peaktable_span_35_2_bef_2_aft_slope_thresh_1'),
mean = c(mean1,mean2,mean3,mean4,mean7,mean8,mean9),
se = c(se1,se2,se3,se4,se7,se8,se9)
)
peak_detection_table table mean se
1 peaktable_span_75_2_consec -22.75000 3.626763
2 peaktable_span_5_2_consec -27.92857 2.244564
3 peaktable_span_75_1_consec -22.75000 3.626763
4 peaktable_span_5_1_consec -27.92857 2.244564
5 peaktable_span_5_2_bef_2_aft_slope_thresh -25.50000 2.773006
6 peaktable_span_5_2_bef_2_aft_slope_thresh_1 -27.07692 2.440212
7 peaktable_span_35_2_bef_2_aft_slope_thresh_1 -24.07143 3.157869Results
Looking at the results of this table it is noted that two of the tables are not represented as they would be a duplicate of two, but used to find the slope ratio for future use. Looking at the results, we see that the first and third table are the closest to the first birth but are also not detecting peaks for 2 of the sows before farrowing. After that the method in which to detect peaks that is closest to farrowing and a peak detected in all current sows before farrowing is the last method in which a peak was detected after a slope change from positive to negative and was negative for at least 2 hours and the slope change ratio was at least 1 using fitted values from a loess function with a span of 0.35.
Now we will make sure that there are no early detections of peaks by adding a rule where it cannot be detected until 10 hours after farrowing
redefining function for a peak not to be detected until 10 hours after training was completed.
find_realtime_peak <- function(win, span = 0.75, consistent_hours = 2, min_slope_ratio = 0.8951308) {
win <- win %>%
filter(!is.na(anomaly_score)) %>%
arrange(ttf)
if (nrow(win) < 10) return(tibble(
status = "Insufficient data",
peak_ttf = NA_real_,
peak_score = NA_real_,
pos_slope = NA_real_,
neg_slope = NA_real_,
slope_ratio = NA_real_
))
# Fit loess on the window's own data
fit <- loess(anomaly_score ~ ttf, data = win, span = span)
ttf_grid <- seq(min(win$ttf), max(win$ttf), length.out = 500)
fitted_vals <- predict(fit, newdata = data.frame(ttf = ttf_grid))
# First derivative
deriv <- diff(fitted_vals) / diff(ttf_grid)
deriv_ttf <- ttf_grid[-1]
# Step size between grid points
step_size <- diff(ttf_grid)[1]
steps_needed <- ceiling(consistent_hours / step_size)
# Zero crossings where slope goes + to -
sign_changes <- which(diff(sign(deriv)) == -2)
if (length(sign_changes) == 0) return(tibble(
status = "No peak yet",
peak_ttf = NA_real_,
peak_score = NA_real_,
pos_slope = NA_real_,
neg_slope = NA_real_,
slope_ratio = NA_real_
))
# For each candidate crossing, check that the slope stays
# negative for the next `consistent_hours` hours
confirmed_crossings <- sign_changes[sapply(sign_changes, function(idx) {
end_idx <- min(idx + steps_needed, length(deriv))
all(deriv[(idx + 1):end_idx] < 0)
})]
if (length(confirmed_crossings) == 0) return(tibble(
status = "No peak yet",
peak_ttf = NA_real_,
peak_score = NA_real_,
pos_slope = NA_real_,
neg_slope = NA_real_,
slope_ratio = NA_real_
))
candidate_ttfs <- deriv_ttf[confirmed_crossings]
candidate_scores <- fitted_vals[confirmed_crossings + 1]
# Only consider peaks between -50 and 0
valid <- which(candidate_ttfs >= -40 & candidate_ttfs <= 0)
if (length(valid) == 0) return(tibble(
status = "No peak yet",
peak_ttf = NA_real_,
peak_score = NA_real_,
pos_slope = NA_real_,
neg_slope = NA_real_,
slope_ratio = NA_real_
))
# For each valid peak, compute slope ratio and filter by threshold
valid_with_ratio <- sapply(valid, function(v) {
best_crossing <- confirmed_crossings[v]
peak_time <- deriv_ttf[best_crossing]
pre_window <- deriv_ttf >= (peak_time - 2) & deriv_ttf < peak_time
post_window <- deriv_ttf > peak_time & deriv_ttf <= (peak_time + 2)
pos_slope <- mean(deriv[pre_window], na.rm = TRUE)
neg_slope <- mean(deriv[post_window], na.rm = TRUE)
slope_ratio <- abs(neg_slope) / pos_slope
# Return TRUE if slope ratio meets threshold
slope_ratio >= min_slope_ratio
})
valid_peaks <- valid[valid_with_ratio]
if (length(valid_peaks) == 0) return(tibble(
status = "No peak yet",
peak_ttf = NA_real_,
peak_score = NA_real_,
pos_slope = NA_real_,
neg_slope = NA_real_,
slope_ratio = NA_real_
))
# Take the highest scoring peak that passes the threshold
best <- valid_peaks[which.max(candidate_scores[valid_peaks])]
best_crossing <- confirmed_crossings[best]
peak_time <- deriv_ttf[best_crossing]
pre_window <- deriv_ttf >= (peak_time - 2) & deriv_ttf < peak_time
post_window <- deriv_ttf > peak_time & deriv_ttf <= (peak_time + 2)
pos_slope <- mean(deriv[pre_window], na.rm = TRUE)
neg_slope <- mean(deriv[post_window], na.rm = TRUE)
slope_ratio <- abs(neg_slope) / pos_slope
tibble(
status = "Peak detected",
peak_ttf = candidate_ttfs[best],
peak_score = candidate_scores[best],
pos_slope = pos_slope,
neg_slope = neg_slope,
slope_ratio = slope_ratio
)
}realtime_table <- nested_df_of_selected %>%
select(sow, rolling_scored) %>%
mutate(
window_results = map(
rolling_scored,
~ map2_dfr(
.x,
cutoffs,
function(win, cut) {
if (is.null(win) || nrow(win) < 10) {
return(tibble(
window_cutoff = cut,
status = "Insufficient data",
peak_ttf = NA_real_,
peak_score = NA_real_,
pos_slope = NA_real_,
neg_slope = NA_real_,
slope_ratio = NA_real_
))
}
result <- find_realtime_peak(win, span = 0.35, consistent_hours = 2, min_slope_ratio = 1)
result %>% mutate(window_cutoff = cut, .before = 1)
}
)
)
) %>%
select(sow, window_results) %>%
unnest(window_results)peaktable_span_35_2_bef_2_aft_slope_thresh_1_10_after_training
# Get first detected peak per sow (first window where peak is confirmed)
peaktable_span_35_2_bef_2_aft_slope_thresh_1_10_after_training <- realtime_table %>%
group_by(sow) %>%
arrange(window_cutoff, .by_group = TRUE) %>%
# Find first window where a peak was detected before farrowing
filter(window_cutoff <= 0) %>%
summarise(
first_peak_row = {
detected <- which(status == "Peak detected")
if (length(detected) == 0) {
tibble(
window_cutoff = NA_integer_,
status = "No peak detected before farrowing",
peak_ttf = NA_real_,
peak_score = NA_real_,
pos_slope = NA_real_,
neg_slope = NA_real_,
slope_ratio = NA_real_
)
} else {
slice(cur_data()[detected[1], ], 1) %>%
select(window_cutoff, status, peak_ttf, peak_score, pos_slope, neg_slope, slope_ratio)
}
},
.groups = "drop"
) %>%
unnest(first_peak_row)
# Display table
peaktable_span_35_2_bef_2_aft_slope_thresh_1_10_after_training %>%
gt() %>%
tab_header(
title = "First Pre-Farrowing Peak Detected per Sow",
subtitle = "First rolling window (TTF -50 to 0) where loess slope consistently changes + to - for 2 hours with a span of 0.35 with a slope ratio threshold of 1 and cannot be detected until 10 hours after training"
) %>%
fmt_number(
columns = c(peak_ttf, peak_score),
decimals = 2,
rows = !is.na(peak_ttf)
) %>%
cols_label(
sow = "Sow",
window_cutoff = "Window Cutoff (TTF)",
status = "Status",
peak_ttf = "Peak TTF (hrs)",
peak_score = "Peak Anomaly Score",
pos_slope = "Slope before peak",
neg_slope = "Slope after peak",
slope_ratio = "Slope ratio ((|Slope after|)/(Slope before))"
) %>%
tab_style(
style = cell_fill(color = "lightgreen"),
locations = cells_body(rows = status == "Peak detected")
) %>%
tab_style(
style = cell_fill(color = "salmon"),
locations = cells_body(rows = status == "No peak detected before farrowing")
) %>%
tab_style(
style = cell_text(weight = "bold"),
locations = cells_column_labels()
)| First Pre-Farrowing Peak Detected per Sow | |||||||
|---|---|---|---|---|---|---|---|
| First rolling window (TTF -50 to 0) where loess slope consistently changes + to - for 2 hours with a span of 0.35 with a slope ratio threshold of 1 and cannot be detected until 10 hours after training | |||||||
| Sow | Window Cutoff (TTF) | Status | Peak TTF (hrs) | Peak Anomaly Score | Slope before peak | Slope after peak | Slope ratio ((|Slope after|)/(Slope before)) |
| 2 | -36 | Peak detected | −39.51 | 0.40 | 0.001883733 | -0.002142726 | 1.137490 |
| 4 | -18 | Peak detected | −31.07 | 0.53 | 0.002760362 | -0.003491940 | 1.265030 |
| 6 | -17 | Peak detected | −24.36 | 0.55 | 0.002734111 | -0.002904701 | 1.062393 |
| 8 | -23 | Peak detected | −30.91 | 0.56 | 0.002390240 | -0.002982088 | 1.247610 |
| 10 | -1 | Peak detected | −20.36 | 0.56 | 0.002822187 | -0.003148288 | 1.115549 |
| 12 | -27 | Peak detected | −34.31 | 0.53 | 0.002032142 | -0.002443242 | 1.202299 |
| 14 | -24 | Peak detected | −33.36 | 0.58 | 0.003712560 | -0.004425856 | 1.192131 |
| 16 | -23 | Peak detected | −28.35 | 0.56 | 0.002507646 | -0.003067844 | 1.223396 |
| 18 | -32 | Peak detected | −38.43 | 0.44 | 0.001349397 | -0.001358858 | 1.007011 |
| 22 | -12 | Peak detected | −30.99 | 0.52 | 0.001648244 | -0.003729223 | 2.262542 |
| 24 | -16 | Peak detected | −23.52 | 0.53 | 0.002234708 | -0.002604654 | 1.165545 |
| 26 | -6 | Peak detected | −12.89 | 0.61 | 0.003758893 | -0.003892039 | 1.035422 |
| 30 | -31 | Peak detected | −37.79 | 0.45 | 0.001783432 | -0.002016456 | 1.130660 |
| 32 | -16 | Peak detected | −35.69 | 0.55 | 0.001728602 | -0.002164718 | 1.252294 |
The average slope ratio is:
mean10 <- mean(peaktable_span_35_2_bef_2_aft_slope_thresh_1_10_after_training$window_cutoff,na.rm=TRUE)
mean10[1] -20.14286With a standard error of:
se10 <- std.error(peaktable_span_35_2_bef_2_aft_slope_thresh_1_10_after_training$window_cutoff,na.rm=TRUE)
se10[1] 2.641297Average anomaly score:
mean_peak_10 <- mean(peaktable_span_35_2_bef_2_aft_slope_thresh_1_10_after_training$peak_score,na.rm=TRUE)
mean_peak_10[1] 0.5256725Table with all average peak detection window cutoff with standard error
peak_detection_table <- data.frame(
method = c('peaktable_span_75_2_consec','peaktable_span_5_2_consec','peaktable_span_75_1_consec','peaktable_span_5_1_consec','peaktable_span_5_2_bef_2_aft_slope_thresh','peaktable_span_5_2_bef_2_aft_slope_thresh_1','peaktable_span_35_2_bef_2_aft_slope_thresh_1','peaktable_span_35_2_bef_2_aft_slope_thresh_1_10_after_training'),
mean = c(mean1,mean2,mean3,mean4,mean7,mean8,mean9,mean10),
se = c(se1,se2,se3,se4,se7,se8,se9,se10)
)
peak_detection_table method mean
1 peaktable_span_75_2_consec -22.75000
2 peaktable_span_5_2_consec -27.92857
3 peaktable_span_75_1_consec -22.75000
4 peaktable_span_5_1_consec -27.92857
5 peaktable_span_5_2_bef_2_aft_slope_thresh -25.50000
6 peaktable_span_5_2_bef_2_aft_slope_thresh_1 -27.07692
7 peaktable_span_35_2_bef_2_aft_slope_thresh_1 -24.07143
8 peaktable_span_35_2_bef_2_aft_slope_thresh_1_10_after_training -20.14286
se
1 3.626763
2 2.244564
3 3.626763
4 2.244564
5 2.773006
6 2.440212
7 3.157869
8 2.641297Results
Now looking at the results after adding a rule of detection 10 hours after training was complete, the average time of where a peak was detected is now 20 hours before farrowing.
Now i want to look at what happens if we add a threshold for the anomaly score
I will use the most recent average anomaly score as the threshold to see how that works
Redefining the function to add a threshold of anomaly score
find_realtime_peak <- function(
win,
span = 0.75,
consistent_hours = 2,
min_slope_ratio = 0.8951308,
min_peak_score = 1.5 # NEW anomaly score threshold
) {
win <- win %>%
filter(!is.na(anomaly_score)) %>%
arrange(ttf)
if (nrow(win) < 10) return(tibble(
status = "Insufficient data",
peak_ttf = NA_real_,
peak_score = NA_real_,
pos_slope = NA_real_,
neg_slope = NA_real_,
slope_ratio = NA_real_
))
# Fit loess
fit <- loess(anomaly_score ~ ttf, data = win, span = span)
ttf_grid <- seq(min(win$ttf), max(win$ttf), length.out = 500)
fitted_vals <- predict(fit, newdata = data.frame(ttf = ttf_grid))
# First derivative
deriv <- diff(fitted_vals) / diff(ttf_grid)
deriv_ttf <- ttf_grid[-1]
step_size <- diff(ttf_grid)[1]
steps_needed <- ceiling(consistent_hours / step_size)
# Detect + to - zero crossings
sign_changes <- which(diff(sign(deriv)) == -2)
if (length(sign_changes) == 0) return(tibble(
status = "No peak yet",
peak_ttf = NA_real_,
peak_score = NA_real_,
pos_slope = NA_real_,
neg_slope = NA_real_,
slope_ratio = NA_real_
))
# Confirm sustained negative slope
confirmed_crossings <- sign_changes[sapply(sign_changes, function(idx) {
end_idx <- min(idx + steps_needed, length(deriv))
all(deriv[(idx + 1):end_idx] < 0)
})]
if (length(confirmed_crossings) == 0) return(tibble(
status = "No peak yet",
peak_ttf = NA_real_,
peak_score = NA_real_,
pos_slope = NA_real_,
neg_slope = NA_real_,
slope_ratio = NA_real_
))
candidate_ttfs <- deriv_ttf[confirmed_crossings]
candidate_scores <- fitted_vals[confirmed_crossings + 1]
# Filter by time window AND anomaly score threshold
valid <- which(
candidate_ttfs >= -40 &
candidate_ttfs <= 0 &
candidate_scores >= min_peak_score
)
if (length(valid) == 0) return(tibble(
status = "No peak yet",
peak_ttf = NA_real_,
peak_score = NA_real_,
pos_slope = NA_real_,
neg_slope = NA_real_,
slope_ratio = NA_real_
))
# Check slope ratio for each valid peak
valid_with_ratio <- sapply(valid, function(v) {
crossing_idx <- confirmed_crossings[v]
peak_time <- deriv_ttf[crossing_idx]
pre_window <- deriv_ttf >= (peak_time - consistent_hours) &
deriv_ttf < peak_time
post_window <- deriv_ttf > peak_time &
deriv_ttf <= (peak_time + consistent_hours)
pos_slope <- mean(deriv[pre_window], na.rm = TRUE)
neg_slope <- mean(deriv[post_window], na.rm = TRUE)
if (is.na(pos_slope) || pos_slope <= 0) return(FALSE)
slope_ratio <- abs(neg_slope) / pos_slope
slope_ratio >= min_slope_ratio
})
valid_peaks <- valid[valid_with_ratio]
if (length(valid_peaks) == 0) return(tibble(
status = "No peak yet",
peak_ttf = NA_real_,
peak_score = NA_real_,
pos_slope = NA_real_,
neg_slope = NA_real_,
slope_ratio = NA_real_
))
# Select highest anomaly score peak
best_idx <- valid_peaks[which.max(candidate_scores[valid_peaks])]
crossing_idx <- confirmed_crossings[best_idx]
peak_time <- deriv_ttf[crossing_idx]
pre_window <- deriv_ttf >= (peak_time - consistent_hours) &
deriv_ttf < peak_time
post_window <- deriv_ttf > peak_time &
deriv_ttf <= (peak_time + consistent_hours)
pos_slope <- mean(deriv[pre_window], na.rm = TRUE)
neg_slope <- mean(deriv[post_window], na.rm = TRUE)
slope_ratio <- ifelse(
is.na(pos_slope) || pos_slope <= 0,
NA_real_,
abs(neg_slope) / pos_slope
)
tibble(
status = "Peak detected",
peak_ttf = candidate_ttfs[best_idx],
peak_score = candidate_scores[best_idx],
pos_slope = pos_slope,
neg_slope = neg_slope,
slope_ratio = slope_ratio
)
}realtime_table <- nested_df_of_selected %>%
select(sow, rolling_scored) %>%
mutate(
window_results = map(
rolling_scored,
~ map2_dfr(
.x,
cutoffs,
function(win, cut) {
if (is.null(win) || nrow(win) < 10) {
return(tibble(
window_cutoff = cut,
status = "Insufficient data",
peak_ttf = NA_real_,
peak_score = NA_real_,
pos_slope = NA_real_,
neg_slope = NA_real_,
slope_ratio = NA_real_
))
}
result <- find_realtime_peak(win, span = 0.35, consistent_hours = 2, min_slope_ratio = 1, min_peak_score=mean_peak_10)
result %>% mutate(window_cutoff = cut, .before = 1)
}
)
)
) %>%
select(sow, window_results) %>%
unnest(window_results)peaktable_span_35_2_bef_2_aft_slope_thresh_1_10_after_training_anom_thresh
# Get first detected peak per sow (first window where peak is confirmed)
peaktable_span_35_2_bef_2_aft_slope_thresh_1_10_after_training_anom_thresh <- realtime_table %>%
group_by(sow) %>%
arrange(window_cutoff, .by_group = TRUE) %>%
# Find first window where a peak was detected before farrowing
filter(window_cutoff <= 0) %>%
summarise(
first_peak_row = {
detected <- which(status == "Peak detected")
if (length(detected) == 0) {
tibble(
window_cutoff = NA_integer_,
status = "No peak detected before farrowing",
peak_ttf = NA_real_,
peak_score = NA_real_,
pos_slope = NA_real_,
neg_slope = NA_real_,
slope_ratio = NA_real_
)
} else {
slice(cur_data()[detected[1], ], 1) %>%
select(window_cutoff, status, peak_ttf, peak_score, pos_slope, neg_slope, slope_ratio)
}
},
.groups = "drop"
) %>%
unnest(first_peak_row)
# Display table
peaktable_span_35_2_bef_2_aft_slope_thresh_1_10_after_training_anom_thresh %>%
gt() %>%
tab_header(
title = "First Pre-Farrowing Peak Detected per Sow",
subtitle = "First rolling window (TTF -50 to 0) where loess slope consistently changes + to - for 2 hours with a span of 0.35 with a slope ratio threshold of 1 and cannot be detected until 10 hours after training with an anomaly threshold of the average anomaly score of 0.5256725"
) %>%
fmt_number(
columns = c(peak_ttf, peak_score),
decimals = 2,
rows = !is.na(peak_ttf)
) %>%
cols_label(
sow = "Sow",
window_cutoff = "Window Cutoff (TTF)",
status = "Status",
peak_ttf = "Peak TTF (hrs)",
peak_score = "Peak Anomaly Score",
pos_slope = "Slope before peak",
neg_slope = "Slope after peak",
slope_ratio = "Slope ratio ((|Slope after|)/(Slope before))"
) %>%
tab_style(
style = cell_fill(color = "lightgreen"),
locations = cells_body(rows = status == "Peak detected")
) %>%
tab_style(
style = cell_fill(color = "salmon"),
locations = cells_body(rows = status == "No peak detected before farrowing")
) %>%
tab_style(
style = cell_text(weight = "bold"),
locations = cells_column_labels()
)| First Pre-Farrowing Peak Detected per Sow | |||||||
|---|---|---|---|---|---|---|---|
| First rolling window (TTF -50 to 0) where loess slope consistently changes + to - for 2 hours with a span of 0.35 with a slope ratio threshold of 1 and cannot be detected until 10 hours after training with an anomaly threshold of the average anomaly score of 0.5256725 | |||||||
| Sow | Window Cutoff (TTF) | Status | Peak TTF (hrs) | Peak Anomaly Score | Slope before peak | Slope after peak | Slope ratio ((|Slope after|)/(Slope before)) |
| 2 | 0 | Peak detected | −8.21 | 0.61 | 0.0029615118 | -0.0029969923 | 1.011981 |
| 4 | -18 | Peak detected | −31.07 | 0.53 | 0.0027603620 | -0.0034919395 | 1.265030 |
| 6 | -17 | Peak detected | −24.36 | 0.55 | 0.0027341115 | -0.0029047010 | 1.062393 |
| 8 | -23 | Peak detected | −30.91 | 0.56 | 0.0023902401 | -0.0029820883 | 1.247610 |
| 10 | -1 | Peak detected | −20.36 | 0.56 | 0.0028221869 | -0.0031482878 | 1.115549 |
| 12 | -27 | Peak detected | −34.31 | 0.53 | 0.0020321423 | -0.0024432422 | 1.202299 |
| 14 | -24 | Peak detected | −33.36 | 0.58 | 0.0037125600 | -0.0044258562 | 1.192131 |
| 16 | -23 | Peak detected | −28.35 | 0.56 | 0.0025076462 | -0.0030678437 | 1.223396 |
| 18 | NA | No peak detected before farrowing | NA | NA | NA | NA | NA |
| 22 | -1 | Peak detected | −10.98 | 0.53 | 0.0007870169 | -0.0009210024 | 1.170245 |
| 24 | -16 | Peak detected | −23.52 | 0.53 | 0.0022347084 | -0.0026046539 | 1.165545 |
| 26 | -6 | Peak detected | −12.89 | 0.61 | 0.0037588930 | -0.0038920393 | 1.035422 |
| 30 | -6 | Peak detected | −15.73 | 0.67 | 0.0015890592 | -0.0016001284 | 1.006966 |
| 32 | -16 | Peak detected | −35.69 | 0.55 | 0.0017286020 | -0.0021647178 | 1.252294 |
The average slope ratio is:
mean11 <- mean(peaktable_span_35_2_bef_2_aft_slope_thresh_1_10_after_training_anom_thresh$window_cutoff,na.rm=TRUE)
mean11[1] -13.69231With a standard error of:
se11 <- std.error(peaktable_span_35_2_bef_2_aft_slope_thresh_1_10_after_training_anom_thresh$window_cutoff,na.rm=TRUE)
se11[1] 2.685155Using this method of a threshold for anomaly score works very well except that there was a single sow that a peak was not detected using the set of rules.
I will now look at a threshold lower at 0.5
realtime_table <- nested_df_of_selected %>%
select(sow, rolling_scored) %>%
mutate(
window_results = map(
rolling_scored,
~ map2_dfr(
.x,
cutoffs,
function(win, cut) {
if (is.null(win) || nrow(win) < 10) {
return(tibble(
window_cutoff = cut,
status = "Insufficient data",
peak_ttf = NA_real_,
peak_score = NA_real_,
pos_slope = NA_real_,
neg_slope = NA_real_,
slope_ratio = NA_real_
))
}
result <- find_realtime_peak(win, span = 0.35, consistent_hours = 2, min_slope_ratio = 1, min_peak_score= 0.5)
result %>% mutate(window_cutoff = cut, .before = 1)
}
)
)
) %>%
select(sow, window_results) %>%
unnest(window_results)peaktable_span_35_2_bef_2_aft_slope_thresh_1_10_after_training_anom_thresh_5
# Get first detected peak per sow (first window where peak is confirmed)
peaktable_span_35_2_bef_2_aft_slope_thresh_1_10_after_training_anom_thresh_5 <- realtime_table %>%
group_by(sow) %>%
arrange(window_cutoff, .by_group = TRUE) %>%
# Find first window where a peak was detected before farrowing
filter(window_cutoff <= 0) %>%
summarise(
first_peak_row = {
detected <- which(status == "Peak detected")
if (length(detected) == 0) {
tibble(
window_cutoff = NA_integer_,
status = "No peak detected before farrowing",
peak_ttf = NA_real_,
peak_score = NA_real_,
pos_slope = NA_real_,
neg_slope = NA_real_,
slope_ratio = NA_real_
)
} else {
slice(cur_data()[detected[1], ], 1) %>%
select(window_cutoff, status, peak_ttf, peak_score, pos_slope, neg_slope, slope_ratio)
}
},
.groups = "drop"
) %>%
unnest(first_peak_row)
# Display table
peaktable_span_35_2_bef_2_aft_slope_thresh_1_10_after_training_anom_thresh_5 %>%
gt() %>%
tab_header(
title = "First Pre-Farrowing Peak Detected per Sow",
subtitle = "First rolling window (TTF -50 to 0) where loess slope consistently changes + to - for 2 hours with a span of 0.35 with a slope ratio threshold of 1 and cannot be detected until 10 hours after training with an anomaly score threshold of 0.5"
) %>%
fmt_number(
columns = c(peak_ttf, peak_score),
decimals = 2,
rows = !is.na(peak_ttf)
) %>%
cols_label(
sow = "Sow",
window_cutoff = "Window Cutoff (TTF)",
status = "Status",
peak_ttf = "Peak TTF (hrs)",
peak_score = "Peak Anomaly Score",
pos_slope = "Slope before peak",
neg_slope = "Slope after peak",
slope_ratio = "Slope ratio ((|Slope after|)/(Slope before))"
) %>%
tab_style(
style = cell_fill(color = "lightgreen"),
locations = cells_body(rows = status == "Peak detected")
) %>%
tab_style(
style = cell_fill(color = "salmon"),
locations = cells_body(rows = status == "No peak detected before farrowing")
) %>%
tab_style(
style = cell_text(weight = "bold"),
locations = cells_column_labels()
)| First Pre-Farrowing Peak Detected per Sow | |||||||
|---|---|---|---|---|---|---|---|
| First rolling window (TTF -50 to 0) where loess slope consistently changes + to - for 2 hours with a span of 0.35 with a slope ratio threshold of 1 and cannot be detected until 10 hours after training with an anomaly score threshold of 0.5 | |||||||
| Sow | Window Cutoff (TTF) | Status | Peak TTF (hrs) | Peak Anomaly Score | Slope before peak | Slope after peak | Slope ratio ((|Slope after|)/(Slope before)) |
| 2 | 0 | Peak detected | −8.21 | 0.61 | 0.002961512 | -0.002996992 | 1.011981 |
| 4 | -18 | Peak detected | −31.07 | 0.53 | 0.002760362 | -0.003491940 | 1.265030 |
| 6 | -17 | Peak detected | −24.36 | 0.55 | 0.002734111 | -0.002904701 | 1.062393 |
| 8 | -23 | Peak detected | −30.91 | 0.56 | 0.002390240 | -0.002982088 | 1.247610 |
| 10 | -1 | Peak detected | −20.36 | 0.56 | 0.002822187 | -0.003148288 | 1.115549 |
| 12 | -27 | Peak detected | −34.31 | 0.53 | 0.002032142 | -0.002443242 | 1.202299 |
| 14 | -24 | Peak detected | −33.36 | 0.58 | 0.003712560 | -0.004425856 | 1.192131 |
| 16 | -23 | Peak detected | −28.35 | 0.56 | 0.002507646 | -0.003067844 | 1.223396 |
| 18 | -3 | Peak detected | −11.19 | 0.51 | 0.001098335 | -0.001248475 | 1.136698 |
| 22 | -12 | Peak detected | −30.99 | 0.52 | 0.001648244 | -0.003729223 | 2.262542 |
| 24 | -16 | Peak detected | −23.52 | 0.53 | 0.002234708 | -0.002604654 | 1.165545 |
| 26 | -6 | Peak detected | −12.89 | 0.61 | 0.003758893 | -0.003892039 | 1.035422 |
| 30 | -6 | Peak detected | −15.73 | 0.67 | 0.001589059 | -0.001600128 | 1.006966 |
| 32 | -16 | Peak detected | −35.69 | 0.55 | 0.001728602 | -0.002164718 | 1.252294 |
The average slope ratio is:
mean12 <- mean(peaktable_span_35_2_bef_2_aft_slope_thresh_1_10_after_training_anom_thresh_5$window_cutoff,na.rm=TRUE)
mean12[1] -13.71429With a standard error of:
se12 <- std.error(peaktable_span_35_2_bef_2_aft_slope_thresh_1_10_after_training_anom_thresh_5$window_cutoff,na.rm=TRUE)
se12[1] 2.43696In changing that slope threshold slightly lower, we are able to get a peak detected on all sows with an average of ~14 hours before farrowing
peak_detection_table <- data.frame(
table = c('peaktable_span_75_2_consec','peaktable_span_5_2_consec','peaktable_span_75_1_consec','peaktable_span_5_1_consec','peaktable_span_5_2_bef_2_aft_slope_thresh','peaktable_span_5_2_bef_2_aft_slope_thresh_1','peaktable_span_35_2_bef_2_aft_slope_thresh_1','peaktable_span_35_2_bef_2_aft_slope_thresh_1_10_after_training','peaktable_span_35_2_bef_2_aft_slope_thresh_1_10_after_training_anom_thresh','peaktable_span_35_2_bef_2_aft_slope_thresh_1_10_after_training_anom_thresh_5'),
mean = c(mean1,mean2,mean3,mean4,mean7,mean8,mean9,mean10,mean11,mean12),
se = c(se1,se2,se3,se4,se7,se8,se9,se10,se11,se12)
)
peak_detection_table table
1 peaktable_span_75_2_consec
2 peaktable_span_5_2_consec
3 peaktable_span_75_1_consec
4 peaktable_span_5_1_consec
5 peaktable_span_5_2_bef_2_aft_slope_thresh
6 peaktable_span_5_2_bef_2_aft_slope_thresh_1
7 peaktable_span_35_2_bef_2_aft_slope_thresh_1
8 peaktable_span_35_2_bef_2_aft_slope_thresh_1_10_after_training
9 peaktable_span_35_2_bef_2_aft_slope_thresh_1_10_after_training_anom_thresh
10 peaktable_span_35_2_bef_2_aft_slope_thresh_1_10_after_training_anom_thresh_5
mean se
1 -22.75000 3.626763
2 -27.92857 2.244564
3 -22.75000 3.626763
4 -27.92857 2.244564
5 -25.50000 2.773006
6 -27.07692 2.440212
7 -24.07143 3.157869
8 -20.14286 2.641297
9 -13.69231 2.685155
10 -13.71429 2.436960