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
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.157869