R Pupil

Mit diesem Dokument werden aus den Dikablis Pupillenrohdaten mit dem Hochschule-München Lichtlabor(D113)-Setup auswertungsfähige Pupillendaten extrahiert. Die Auswertung ist gültig für das “Programm 5” aus dem Lightdome-Steuerrechner und für die “neue” Umrechnungsmethode von Pixeln zu mm, bei der vor Aufzeichnung ein Referenzmaß auf Augenebene im Kamerabild gezeigt wird. Dieses Programm beginnt mit einer Dunkeladapationsperiode von 90 Sekunden. Danach werden in ca. 15 Sekunden-Schritten die Wellenlängen von 700-400 nm in 5 nm Schritten abgefahren.

Um den Code für eine neue Person anzupassen, sind die folgenden Eingriffe notwendig. Zeilenangaben beziehen sich auf das *.Rmd-File:

1. Zeile 37 -> Einfügen des korrekten Dateinamens / Pfad

2. Zeile 45 -> Versuchspersonencode einfügen

3. Zeilen 116-128 -> Prüfung, ob die Kriterien zur Messwertaussortierung bei Zirkularität, absolutem Abschnitt, und dem Schlussschnitt in Ordnung sind

4. Zeile 212-215 -> Nach Prüfung, ob die Tal-Erkennung funktioniert, Angabe des korrekten Index für den Referenzzeitpunkt. Sollte das beim linken Auge nicht möglich sein, muss der unterste Code-Chunk aus der Datei manuell hoch kopiert werden. Sollte der erste Beleuchtungszeitpunkt nicht erkannt werden, kann ein späterer Zeitpunkt angegeben werden - in diesem Fall muss spezifiziert werden, um wie viele Schritte der Programmstart zurückliegt.

5. Zeile 428/429 -> Die Auswahl, welches Auge schlussendlich für den Datenexport verwendet wird, wird standardmäßig automatisch vollzogen anhand der Pupille mit dem meisten Datenpunkten nach der Bereinigung. Sollte diese Auswahl nicht in Ordnung sein, muss hier manuell “R” oder “L” eingetragen werden.

Im folgenden Abschnitt werden alle notwendigen Bibliotheken geladen, sowie die Rohdaten eingelesen. Der Abschnitt endet mit einer Darstellung der Rohdaten der Pupillen, sowie der Zirkulariät.

library(tidyverse)

Es gab 11 Warnungen (Anzeige mit warnings())

library(anytime)
library(signal)
library(ggplot2)
library(cowplot)
library(ggpmisc)
library(readxl)
library(knitr)

setwd(dirname(rstudioapi::getActiveDocumentContext()$path)) # Setzen des Arbeitsverzeichnisses auf gleiches Verzeichnis wie Script 

pup <- read.table("../data_input/Down/EM111201_2. Messung 24.08.2020 171119_CsvData.txt", sep = "\t", header = TRUE, stringsAsFactors=F) # Einlesen der Daten Pupille
prog <- read.table("../data_input/program_data_ld.csv", dec = ",", sep = ";", header = TRUE, stringsAsFactors=F) # Einlesen der Programmdaten
corf <- read_excel("../Übersicht_VP.xlsx", sheet = "Uebersicht_VP", na="NA") #load in the file with all individual codes # Einlesen der Korrekturfaktoren

#Auswählen der notwendigen Spalten und Spalten umbenennen
#Umrechnen des UTC-Zeitstempels in lokale Zeit
#Berechnung des Pupillendurchmessers (nur für Referenzmaß - Die Korrekturfaktoren aller Probanden werden in einer separaten Datei gespeichert)

Code <- "EM111201"

dir.create(paste("../figures/", Code, sep=""))

pup <- select(pup, rec_time, UTC, Dikablis.Professional_Eye.Data_Original_Left.Eye_Pupil.Area, Dikablis.Professional_Eye.Data_Original_Left.Eye_Pupil.Height, Dikablis.Professional_Eye.Data_Original_Left.Eye_Pupil.Width, Dikablis.Professional_Eye.Data_Original_Right.Eye_Pupil.Area, Dikablis.Professional_Eye.Data_Original_Right.Eye_Pupil.Height, Dikablis.Professional_Eye.Data_Original_Right.Eye_Pupil.Width) 

pup <- tibble(pup)

colnames(pup) <- c("time", "UTC", "La", "Lh", "Lw", "Ra", "Rh", "Rw")

pup$UTC <- anytime(pup$UTC/1000)

pup <- separate(pup, time, c("h", "m", "s"), sep = ":", convert = TRUE)
pup$time <- pup$s + pup$m*60 + pup$h*60*60

corf_L <- corf$Korr_Links[corf$Code == Code]
corf_R <- corf$Korr_Rechts[corf$Code == Code]

pup$Ld <- 2*sqrt(pup$La/pi)/corf_L

pup$Rd <- 2*sqrt(pup$Ra/pi)/corf_R

#Aufteilen in Pupille rechtes und linkes Auge

pupR <- select(pup, "time", "UTC", "Rd", "Ra", "Rh", "Rw")
pupR <- dplyr::filter(pupR, !is.na(Ra))
colnames(pupR) <- c("time", "UTC", "dia", "area", "height", "width")

pupL <- select(pup, "time", "UTC", "Ld", "La", "Lh", "Lw")
pupL <- dplyr::filter(pupL, !is.na(La))
colnames(pupL) <- c("time", "UTC", "dia", "area", "height", "width")

#Darstellung der Ergebnisse im Plot
# Rohdaten
Roh_plot <- ggplot() + 
  geom_line(data = pupL, aes(x = time, y = dia, col = "Left")) +
  geom_line(data = pupR, aes(x = time, y = dia, col = "Right"), alpha = 0.6) +
  geom_text(aes(label = paste("n=1, ", Code, ", Down", sep=""), x = 50, y= 8), size = 2.5)+
  theme_cowplot(font_size = 8, font_family = "sans")+
  scale_color_brewer(palette = "Set1", "Eye")+
  ggtitle("Pupil-diameter data unchanged")+
  ylab("Pupil diameter / mm") +
  xlab("Time / seconds")+
  theme(legend.position = c(0.9,.1),legend.background = element_rect(fill="white", size = 0.5))

Roh_plot
ggsave("Pupil_Raw.pdf", path = paste("../figures/", Code, sep=""), width=10, height = 5)

# Zirkularität
Roh_plot2 <- ggplot() + 
  geom_line(data = pupL, aes(x = time, y = width/height, col = "Left")) +
  geom_line(data = pupR, aes(x = time, y = width/height, col = "Right"), alpha = 0.6) +
  geom_text(aes(label = paste("n=1, ", Code, ", Down",  sep=""), x = 50, y= 1.01), size = 2.5)+
  theme_cowplot(font_size = 8, font_family = "sans")+
  scale_color_brewer(palette = "Set1", "Eye")+
  ggtitle("Pupil-circularity")+
  ylab("Pupil diameter / mm") +
  xlab("Time / seconds")+
  theme(legend.position = c(0.9,.1),legend.background = element_rect(fill="white", size = 0.5))

Roh_plot2
ggsave("Pupil_Raw2.pdf", path = paste("../figures/", Code, sep=""), width=10, height = 5)

NA
NA

Im kommenden Abschnitt werden Artefakte und unplausible Messwerte entfernt. Zudem wird die Kurve geglättet.

#Entfernung von Ausreissern und Werten bei denen die Pupille eine zirkularität < 0,7 aufweist, zudem wird die letzten 2 Sekunden der Messung entfernt

pupRf <- pupR[1:(length(pupR$time)-120),]
pupRf <- dplyr::filter(pupRf, dia > 1) # Entfernung von Werten kleiner X mm
pupRf <- dplyr::filter(pupRf, dia < 8.5) # Entfernung von Werten größer 8 mm
pupRf <- dplyr::filter(pupRf, width/height > 0.70 & width/height > 0.70) # Entfernung von Werten für die die Zirkularität kleiner als 0,7 ausfällt
pupRf$dia_sm <- sgolayfilt(pupRf$dia, p=3, n=31) # Glättung der Kurve mittels Savitzky-Golay Filter

pupLf <- pupL[1:(length(pupL$time)-120),]
pupLf <- dplyr::filter(pupLf, dia > 1) # Entfernung von Werten kleiner X mm
pupLf <- dplyr::filter(pupLf, dia < 8.5) # Entfernung von Werten größer 8 mm
pupLf <- dplyr::filter(pupLf, width/height > 0.70 & width/height > 0.70) # Entfernung von Werten für die die Zirkularität kleiner als 0,7 ausfällt
pupLf$dia_sm <- sgolayfilt(pupLf$dia, p=3, n=31) # Glättung der Kurve mittels Savitzky-Golay Filter

Smooth_plot_test <- ggplot() + 
  geom_line(data = pupLf, aes(x = time, y = dia, col = "unsmoothed")) +
  geom_line(data = pupLf, aes(x = time, y = dia_sm, col = "sg n=31"), alpha = 0.6) +
    geom_line(data = pupLf, aes(x = time, y = sgolayfilt(dia, p=3, n=61), col = "sg n=61"), alpha = 0.6) +
    geom_line(data = pupLf, aes(x = time, y = sgolayfilt(dia, p=3, n=91), col = "sg n=91"), alpha = 0.6) +
  geom_text(aes(label = paste("n=1, ", Code,  ", Down", sep=""), x = 50, y= 8), size = 2.5)+
  theme_cowplot(font_size = 8, font_family = "sans")+
  scale_color_brewer(palette = "Set1", "Eye")+
  ggtitle("Pupil-diameter data smoothed, test settings")+
  ylab("Pupil diameter / mm") +
  xlab("Time / seconds")+
  theme(legend.position = c(0.9,.1),legend.background = element_rect(fill="white", size = 0.5))+
  coord_cartesian(xlim = c(250, 275), ylim = c(2,8))

Smooth_plot_test
ggsave("Pupil_Smooth_test.pdf", path = paste("../figures/", Code, sep=""), width=10, height = 5)

Smooth_plot <- ggplot() + 
  geom_line(data = pupLf, aes(x = time, y = dia_sm, col = "Left")) +
  geom_line(data = pupRf, aes(x = time, y = dia_sm, col = "Right"), alpha = 0.6) +
  geom_text(aes(label = paste("n=1, ", Code,  ", Down", sep=""), x = 50, y= 8), size = 2.5)+
  theme_cowplot(font_size = 8, font_family = "sans")+
  scale_color_brewer(palette = "Set1", "Eye")+
  ggtitle("Pupil-diameter data smoothed")+
  ylab("Pupil diameter / mm") +
  xlab("Time / seconds")+ 
  coord_cartesian(ylim = c(2,8))+
  theme(legend.position = c(0.9,.1),legend.background = element_rect(fill="white", size = 0.5))

Smooth_plot
ggsave("Pupil_Smooth.pdf", path =  paste("../figures/", Code, sep=""), width=10, height = 5)

NA
NA

Im nächsten Abschnitt erfolgt die Zuordnung einzelner Zeitabschnitte zu den Wellenlängen.

#Bildung der 1. und 2. Ableitung. Lineare Transformation, damit die Überlagerung mit dem Pupillendurchmesser lesbar bleibt.

pupLf$dia_sm1 <- (sgolayfilt(pupLf$dia, p=3, n=31, m=1))*100+6
pupLf$dia_sm2 <- (sgolayfilt(pupLf$dia, p=3, n=31, m=2))*100+6


#Erkennung der Tiefpunkte der 2. Ableitung
vly <- ggplot(data = pupLf, aes(x=time, y=dia_sm2)) + 
  stat_valleys(span = 601, col = "green")
vly_data <- (layer_data(vly, i=1L)$xintercept)

#Darstellung der Tiefpunkte der 2. Ableitung
Derivative_test <- ggplot(data = pupLf, aes(x=time, y=dia_sm2, col="valley")) + 
  geom_line(data = pupLf, aes(x = time, y = dia_sm, col = "Diameter")) +
  geom_line(data = pupRf, aes(x = time, y = dia_sm, col = "Diameter")) +
    geom_line(aes(col = "2nd derivative"), alpha = 0.6) +
  stat_valleys(span = 601, col = "green")+
  geom_vline(xintercept = vly_data-0.1, lwd = 0.1, col="green")+
  geom_text(aes(label = paste("n=1, ", Code,  ", Down", sep=""), x = 50, y= 8), size = 2.5)+
  theme_cowplot(font_size = 8, font_family = "sans")+
  scale_color_brewer(palette = "Set1", "Type")+
  ggtitle("Pupil-diameter data smoothed with 2nd derivative and valleys (-100ms)")+
  ylab("Pupil diameter / mm") +
  xlab("Time / seconds")+
  theme(legend.position = c(0.9,.1),legend.background = element_rect(fill="white", size = 0.5))+
  coord_cartesian(xlim = c(80, 200))

Derivative_test
ggsave("Pupil_Derivative_test.pdf", path = paste("../figures/", Code, sep=""), width=15, height = 5)

#Wahl eine Programmstartpunkts

vly_data <- tibble("index" = 1: length(vly_data), "time" = vly_data-0.1, "dif" = c(vly_data[1], diff(vly_data)))
kable(vly_data[1:20,], "pandoc", caption = "Time of 2nd derivative valleys (-100ms), first 20 rows", align = "c")# Tiefpunkte mit Zeitstempel

Time of 2nd derivative valleys (-100ms), first 20 rows

index	time	dif
1	7.714	7.814
2	16.647	8.933
3	25.847	9.200
4	43.964	18.117
5	58.497	14.533
6	67.380	8.883
7	84.280	16.900
8	98.780	14.500
9	107.564	8.784
10	126.780	19.216
11	135.597	8.817
12	144.264	8.667
13	149.864	5.600
14	158.830	8.966
15	174.464	15.634
16	183.714	9.250
17	189.597	5.883
18	204.780	15.183
19	219.880	15.100
20	225.564	5.684

NA

sequ_per <- 15.145 #Sequenz Periode -> Ermittlung aus Video mit Geräuschanalyse

#Welcher index ist der Startzeitpunkt?
i <- 8 # Hier muss man auf Basis der Grafik und der Tabelle den Startzeitpunkt angeben

#Zeitkorrektur notwendig?
cor <- 0

pupLf$time_c <- pupLf$time - vly_data$time[vly_data$index == i] + sequ_per*cor
pupRf$time_c <- pupRf$time - vly_data$time[vly_data$index == i] + sequ_per*cor


#Ergänzung der Wellenlängen 

wl_sec <- tibble(
  "wl" = rev(prog$Peak_5), 
  "wl_b" = seq(from = 0, to = (length(prog$Peak_5)-1)*sequ_per, by = sequ_per),
  "wl_e" = seq(from = sequ_per, to = length(prog$Peak_5)*sequ_per, by = sequ_per)
  )

tot_per <- length(prog$Peak_5)*sequ_per

sequ <- seq(from=0, to = tot_per, by = sequ_per)
wl <- rev(prog$Peak_5)
prog$index <- length(prog$Peak_5):1

pupLf$wl_step <- as.numeric(cut(pupLf$time_c,
               breaks = sequ,
               include.lowest = T,
               right = F,
               labels = wl))

pupLf$wl_time <-  pupLf$time_c - (pupLf$wl_step-1)*sequ_per

pupLf$wl_step <- wl[pupLf$wl_step]


pupRf$wl_step <- as.numeric(cut(pupRf$time_c,
               breaks = sequ,
               include.lowest = T,
               right = F,
               labels = wl))

pupRf$wl_time <-  pupRf$time_c - (pupRf$wl_step - 1)*sequ_per

pupRf$wl_step <- wl[pupRf$wl_step]

#Darstellung der Daten mit neuem Start und den jeweiligen Wellenlängen

Timed_plot <- ggplot() + 
  geom_rect(data = wl_sec, aes(xmin= wl_b, xmax = wl_e, ymin = 2, ymax = 8, fill = wl))+
  geom_line(data = pupLf, aes(x = time_c, y = dia_sm, col = "Left")) +
  geom_line(data = pupRf, aes(x = time_c, y = dia_sm, col = "Right"), alpha = 0.6) +
  geom_text(aes(label = paste("n=1, ", Code,  ", Down", sep=""), x = 50, y= 7.5), size = 2.5)+
  theme_cowplot(font_size = 8, font_family = "sans")+
  scale_color_manual(values = c("grey80", "black"))+
  scale_fill_gradientn(colors = c(rev(rainbow(53, start = 0, end = 0.80)), rev(rainbow(8, start = 0.94, end = 1))))+
  ggtitle("Pupil-diameter during different wavelength")+
  ylab("Pupil diameter / mm") +
  xlab("Time / seconds")+ 
  coord_cartesian(ylim = c(2,8))+
  theme(legend.position = c(0.85,.22),legend.background = element_rect(fill="white", size = 0.5))

Timed_plot
ggsave("Timed_Smooth.pdf", path =  paste("../figures/", Code, sep=""),limitsize=F, width=20, height = 5)

 WL_plot <- ggplot() + 
  geom_line(data = pupLf, aes(x = as.factor(wl_step), y = dia_sm, col = "Left")) +
  geom_line(data = pupRf, aes(x = as.factor(wl_step), y = dia_sm, col = "Right"), alpha = 0.6) +
  geom_text(aes(label = paste("n=1, ", Code,  ", Down", sep=""), x = 50, y= 8), size = 2.5)+
  theme_cowplot(font_size = 8, font_family = "sans")+
  scale_color_brewer(palette = "Set1", "Eye")+
  ggtitle("Pupil-diameter per wavelength")+
  ylab("Pupil diameter / mm") +
  xlab("wavelength / nm")+ 
  coord_cartesian(ylim = c(2,8))+
  theme(legend.position = c(0.9,.1),legend.background = element_rect(fill="white", size = 0.5))

WL_plot
ggsave("Wavelength_Plot.pdf", path =  paste("../figures/", Code, sep=""),limitsize=F, width=10, height = 5)

WL_plot2 <- ggplot() + 
  geom_line(data = pupLf, aes(x = wl_time, y = dia_sm, group = wl_step, col = wl_step)) +
  geom_text(aes(label = paste("n=1, ", Code,  ", Down", sep=""), x = 0.5, y= 8), size = 2.5)+
  theme_cowplot(font_size = 8, font_family = "sans")+
  scale_color_gradientn(colors = c(rev(rainbow(53, start = 0, end = 0.80)), rev(rainbow(8, start = 0.94, end = 1))))+
  ggtitle("Pupil-diameter depending on wavelength")+
  ylab("Pupil diameter / mm") +
  xlab("Time / seconds")+ 
  coord_cartesian(ylim = c(2,8))+
  theme(legend.position = c(0.9,.1),legend.background = element_rect(fill="white", size = 0.5))

WL_plot2
ggsave("Wavelength_Plot2.pdf", path =  paste("../figures/", Code, sep=""),limitsize=F, width=10, height = 7.5)

WL_plot2log <- ggplot() + 
  geom_line(data = pupLf, aes(x = log10(wl_time), y = dia_sm, group = wl_step, col = wl_step)) +
  geom_text(aes(label = paste("n=1, ", Code,  ", Down", sep=""), x = -1, y= 8), size = 2.5)+
  theme_cowplot(font_size = 8, font_family = "sans")+
  scale_color_gradientn(colors = c(rev(rainbow(53, start = 0, end = 0.80)), rev(rainbow(8, start = 0.94, end = 1))))+
  ggtitle("Pupil-diameter depending on wavelength")+
  ylab("Pupil diameter / mm") +
  xlab("Time / log10(seconds)")+ 
  coord_cartesian(ylim = c(2,8), xlim = c(-1.5, log10(15)))+
  theme(legend.position = c(0.9,.1),legend.background = element_rect(fill="white", size = 0.5))

WL_plot2log
ggsave("Wavelength_Plot2log.pdf", path =  paste("../figures/", Code, sep=""),limitsize=F, width=10, height = 7.5)

Im folgenden Abschnitt werden Mittelwerte für jede Sekunde des Lichtreizes gebildet. Diese werden normiert, bezogen auf die Differenz zwischen der maximalen und minimalen Pupillenweite.

# Zunächst wird die -Baseline-Größe bestimmt. Sie wird hier definiert als der Mittelwert der Pupille in den letzten 5 Sekunden der Dunkeladaptation
# In Fällen, in denen die Pupille während der Belichtung niedrigere Werte annimmt, kann auch die größte Pupillengröße während der Belichtung gewählt werden. Dies erfolgt automatisch anhand des größeren Werts

L_norm <- as.numeric(
                  ifelse(pupLf %>% dplyr::filter(time_c < 0 & time_c > -5)  %>% summarize(p_max = mean(dia_sm)) > 
                   pupLf %>% dplyr::filter(time_c > 0 & time_c < tot_per)  %>% summarize(p_max = max(dia_sm)), 
                 pupLf %>% dplyr::filter(time_c < 0 & time_c > -5)  %>% summarize(p_max = mean(dia_sm)), 
                 pupLf %>% dplyr::filter(time_c > 0 & time_c < tot_per)  %>% summarize(p_max = max(dia_sm))
                 ))

# Im nächsten Schritt werden die Sekundenmittelwerte für jede Wellenlänge gebildet, zudem der Mittelwert der letzten 5 Sekunden und die minimalen Pupillengrößen für die jeweiligen Zeitintervalle

L_val <- pupLf %>% group_by(wl_step, wl_time %/% 1) %>% summarize(d_abs = mean(dia_sm))

`summarise()` regrouping output by 'wl_step' (override with `.groups` argument)

L_val10 <- pupLf %>% dplyr::filter(wl_time <= 15 & wl_time >= 10)  %>% group_by(wl_step) %>% summarize(d_abs = mean(dia_sm))

`summarise()` ungrouping output (override with `.groups` argument)

names(L_val) <- c("wl", "time", "d_abs")
names(L_val10) <- c("wl", "d_abs")

temp <- L_val %>% dplyr::filter(wl != "NA") %>% group_by(time) %>% summarize(min = min(d_abs))

`summarise()` ungrouping output (override with `.groups` argument)

L_norm <- data_frame("Cond" = c("Dark", temp$time, "10_15"), "dia" = c(L_norm, temp$min, min(L_val10$d_abs)))


# Hier wird zunächst eine temporäre Variable erzeugt, welche für jede Zeile in den Sekundenmittelwertdaten die korrespondierende minimale Pupillengröße angibt.

temp <- as.numeric(as.character((cut(L_val$time,
               breaks = 0:(sequ_per %/% 1 +1),
               include.lowest = T,
               right = F,
               labels = L_norm$dia[2:(length(L_norm$dia)-1)]))
)) 


# Im folgenden Schritt werden relative Pupillenkonstriktionswerte gebildet, amp ist dabei die Konstriktionsamplitude bezogen auf die Baseline-Größe, amp2 auf die Spanne zwischen der Basline-Größe und der kleinsten, für diese Zeitspanne gemessenen Pupillengröße.

L_val$amp <- (L_norm$dia[L_norm$Cond == "Dark"] - L_val$d_abs)/L_norm$dia[L_norm$Cond == "Dark"]*100
L_val10$amp <- (L_norm$dia[L_norm$Cond == "Dark"] - L_val10$d_abs)/L_norm$dia[L_norm$Cond == "Dark"]*100

L_val$amp2 <- (L_norm$dia[L_norm$Cond == "Dark"] - L_val$d_abs)/(L_norm$dia[L_norm$Cond == "Dark"] - temp)*100
L_val10$amp2 <- (L_norm$dia[L_norm$Cond == "Dark"] - L_val10$d_abs)/(L_norm$dia[L_norm$Cond == "Dark"] - L_norm$dia[L_norm$Cond == "10_15"])*100

##Nun auch für das rechte Auge
# Zunächst wird die -Baseline-Größe bestimmt. Sie wird hier definiert als der Mittelwert der Pupille in den letzten 5 Sekunden der Dunkeladaptation
# In Fällen, in denen die Pupille während der Belichtung niedrigere Werte annimmt, kann auch die größte Pupillengröße während der Belichtung gewählt werden. Dies erfolgt automatisch anhand des größeren Werts

R_norm <- as.numeric(
                  ifelse(pupRf %>% dplyr::filter(time_c < 0 & time_c > -5)  %>% summarize(p_max = mean(dia_sm)) > 
                   pupRf %>% dplyr::filter(time_c > 0 & time_c < tot_per)  %>% summarize(p_max = max(dia_sm)), 
                 pupRf %>% dplyr::filter(time_c < 0 & time_c > -5)  %>% summarize(p_max = mean(dia_sm)), 
                 pupRf %>% dplyr::filter(time_c > 0 & time_c < tot_per)  %>% summarize(p_max = max(dia_sm))
                 ))

# Im nächsten Schritt werden die Sekundenmittelwerte für jede Wellenlänge gebildet, zudem der Mittelwert der letzten 5 Sekunden und die minimalen Pupillengrößen für die jeweiligen Zeitintervalle

R_val <- pupRf %>% group_by(wl_step, wl_time %/% 1) %>% summarize(d_abs = mean(dia_sm))

`summarise()` regrouping output by 'wl_step' (override with `.groups` argument)

R_val10 <- pupRf %>% dplyr::filter(wl_time <= 15 & wl_time >= 10)  %>% group_by(wl_step) %>% summarize(d_abs = mean(dia_sm))

`summarise()` ungrouping output (override with `.groups` argument)

names(R_val) <- c("wl", "time", "d_abs")
names(R_val10) <- c("wl", "d_abs")

temp <- R_val %>% dplyr::filter(wl != "NA") %>% group_by(time) %>% summarize(min = min(d_abs))

`summarise()` ungrouping output (override with `.groups` argument)

R_norm <- data_frame("Cond" = c("Dark", temp$time, "10_15"), "dia" = c(R_norm, temp$min, min(R_val10$d_abs)))



# Im folgenden Schritt werden relative Pupillenkonstriktionswerte gebildet, amp ist dabei die Konstriktionsamplitude bezogen auf die Baseline-Größe, amp2 auf die Spanne zwischen der Basline-Größe und der kleinsten, für diese Zeitspanne gemessenen Pupillengröße.

temp <- as.numeric(as.character((cut(R_val$time,
               breaks = 0:(sequ_per %/% 1 +1),
               include.lowest = T,
               right = F,
               labels = R_norm$dia[2:(length(R_norm$dia)-1)]))
)) # Hier wird zunächst eine temporäre Variable erzeugt, welche für jede Zeile in den Sekundenmittelwertdaten die korrespondierende minimale Pupillengröße angibt.

R_val$amp <- (R_norm$dia[R_norm$Cond == "Dark"] - R_val$d_abs)/R_norm$dia[R_norm$Cond == "Dark"]*100
R_val10$amp <- (R_norm$dia[R_norm$Cond == "Dark"] - R_val10$d_abs)/R_norm$dia[R_norm$Cond == "Dark"]*100

R_val$amp2 <- (R_norm$dia[R_norm$Cond == "Dark"] - R_val$d_abs)/(R_norm$dia[R_norm$Cond == "Dark"] - temp)*100
R_val10$amp2 <- (R_norm$dia[R_norm$Cond == "Dark"] - R_val10$d_abs)/(R_norm$dia[R_norm$Cond == "Dark"] - R_norm$dia[R_norm$Cond == "10_15"])*100


#Abschließend die grafische Darstellung
Sens <-  ggplot() +
  geom_line(data = L_val, aes(x=wl, y=amp2, group = time, col = "Left"), alpha = 0.25) +
  geom_line(data = R_val, aes(x=wl, y=amp2, group = time, col = "Right"), alpha = 0.25) +
  geom_line(data = L_val10, aes(y=amp2, x=wl, col = "Left"), lwd = 1)+
  geom_line(data = R_val10, aes(y=amp2, x=wl, col = "Right"), lwd = 1)+
  geom_text(aes(label = paste("n=1, ", Code, ", Down", sep=""), x = 400, y= 100), size = 2.5)+
  theme_cowplot(font_size = 8, font_family = "sans")+
  scale_color_brewer(palette = "Set1", "Eye")+
  ggtitle("Sensitivity depending on wavelength and time (1-15 per second averages in lighter tone)")+
  ylab("Sensitivity / %") +
  xlab("Wavelength / nm")+ 
  theme(legend.position = c(0.9,.2),legend.background = element_rect(fill="white", size = 0.5))

Sens
ggsave("Sensitivity.pdf", path =  paste("../figures/", Code, sep=""),limitsize=F, width=10, height = 6)

Schließlich erfolgt der Export der Mittelwerte für alle Wellenlängen, sowie für die Normierungsrandbedingungen

#Entscheidung für ein Auge, auf Basis der meisten Datenverfügbarkeit, sofern nicht manuell etwas angegeben wird.

export <- ifelse(length(pupLf$dia_sm) > length(pupRf$dia_sm), "L", "R")


paste("the pupil of the following eye is used for export: ", ifelse(export == "R", "Right", "Left"))

[1] "the pupil of the following eye is used for export:  Right"

#Erstellung der Exportdaten für die Sekundenmittelwerte, die 10-15 Sekundenmittelwerte, und für die Normierungsrandbedingungen

temp <- get(paste(export, "_norm", sep=""))
export_data3 <- data.frame(t(temp[-1]))
colnames(export_data3) <- temp$Cond
export_data3 <- tibble("Code" = Code, "Eye" = ifelse(export == "R", "Right", "Left"), "Date" = as.Date(pup$UTC[1]), "Time" = format(as.POSIXct(pup$UTC[1]), format = "%H:%M:%S"), "Dir" = "Down", export_data3)

export_data0 <- get(paste("pup", export, "f", sep=""))
export_data0$amp1 <- (export_data3$Dark[1] - export_data0$dia_sm)/export_data3$Dark[1]*100

export_data1 <- get(paste(export, "_val", sep=""))[-length(get(paste(export, "_val", sep=""))$wl),]
export_data1$index <- match(export_data1$wl, wl)

export_data2 <- get(paste(export, "_val10", sep=""))
export_data2$index <- match(export_data2$wl, wl)

write_csv(export_data0, paste("../data_output/", Code, "_full.csv", sep="") )
write_csv(export_data1, paste("../data_output/", Code, "_all.csv", sep="") )
write_csv(export_data2, paste("../data_output/", Code, "_10_15.csv", sep="") )
write_csv(export_data3, paste("../data_output/", Code, "_norm.csv", sep="") )

#---- Anfang Code-Option

#Alternativ, wenn mit dem Rechten Auge die Zeit erfasst wird.

#Bildung der 1. und 2. Ableitung. Lineare Transformation, damit die Überlagerung mit dem Pupillendurchmesser lesbar bleibt.

pupRf$dia_sm1 <- (sgolayfilt(pupRf$dia, p=3, n=31, m=1))*100+6
pupRf$dia_sm2 <- (sgolayfilt(pupRf$dia, p=3, n=31, m=2))*100+6


#Erkennung der Tiefpunkte der 2. Ableitung
vly <- ggplot(data = pupRf, aes(x=time, y=dia_sm2)) + 
   stat_valleys(span = 601, col = "green")
 vly_data <- (layer_data(vly, i=1L)$xintercept)

#Darstellung der Tiefpunkte der 2. Ableitung
 Derivative_test <- ggplot(data = pupRf, aes(x=time, y=dia_sm2, col="valley")) + 
   geom_line(data = pupRf, aes(x = time, y = dia_sm, col = "Diameter")) +
   geom_line(data = pupLf, aes(x = time, y = dia_sm, col = "Diameter")) +
     geom_line(aes(col = "2st derivative"), alpha = 0.6) +
   stat_valleys(span = 601, col = "green")+
   geom_vline(xintercept = vly_data-0.1, lwd = 0.1, col="green")+
   geom_text(aes(label = paste("n=1, ", Code, sep=""), x = 50, y= 8), size = 2.5)+
   theme_cowplot(font_size = 8, font_family = "sans")+
   scale_color_brewer(palette = "Set1", "Type")+
   ggtitle("Pupil-diameter data smoothed with 2nd derivative and valleys (-100ms)")+
   ylab("Pupil diameter / mm") +
   xlab("Time / seconds")+
   theme(legend.position = c(0.9,.1),legend.background = element_rect(fill="white", size = 0.5))+
   coord_cartesian(xlim = c(85, 150))

 Derivative_test
 ggsave("Pupil_Derivative_test.pdf", path = paste("../figures/", Code, sep=""), width=10, height = 5)

#Wahl eines Programmstartpunkts

vly_data <- tibble("index" = 1: length(vly_data), "time" = vly_data-0.1, "dif" = c(vly_data[1], diff(vly_data)))
kable(vly_data[1:20,], "pandoc", caption = "Time of 2nd derivative valleys (-100ms), first 20 rows", align = "c")# Tiefpunkte mit Zeitstempel

#---- Ende Code-Option