.Rhistory

tb_pit$date <- ymd(tb_pit$date)
tb_pit <- tb_pit %>% rename(date_pit=date)
tb$date <- ymd(tb$date)
tb_obs_pit <-
tb %>%
mutate(observation = row_number()) %>%
left_join(tb_pit,by="pit") %>%
filter(!is.na(date_pit)) %>%
filter(date_pit <= date) %>%
arrange(date_pit) %>%
group_by(observation) %>%
summarise(ID = ID[n()])
tb %>%
mutate(observation = row_number()) %>%
left_join(tb_obs_pit,by="observation") %>%
select(-observation)
}
#' @title re_dnaID
#' @export
re_dnaID <- function(tb,tb_rednaid){
require(glue)
#1: Go through each row in the rednaID table
#2: for the given pit, and date:
#3: find the item in the datepit table with:
#4: the same pit
#5: that was registered the time before that datepit
#6 then, rename the ID in that item with the one from the current row in the rednaID table
for( i_row in 1:nrow(tb_rednaid) )
{
row <- tb_rednaid[i_row,]
pit <- row$pit
date <- row$date
dnaid <- row$dnaID
if(nrow( tb[tb$pit==pit & tb$date < date,])==0) message(glue("re-dnaid: pit {pit} for id {dnaid} and date {date} not found"))
tb[tb$pit==pit & tb$date < date,][1,][["ID"]] <- dnaid
}
return(tb)
}
#' @export
write_datepit_file <- function(tb, finclip_matches){
identify_fleeters <- function(tb_pits){
tb_lonely_measurements <-
tb_pits %>%
group_by(i_measurement) %>%
summarise(
lonely = if_else(sum(!is.na(pit)) == 1 & all(is.na(dnaID)),T,F)
) %>% ungroup()
# if first mention of pit is missing dnaID and another pit (is lonely), make fleeter
# alternatively, if a "pit_new" is lonely, also make fleeter
tb_pits %>%
left_join(tb_lonely_measurements,by="i_measurement") %>%
group_by(pit) %>%
arrange(date) %>%
filter(pit!="" & !is.na(pit)) %>%
mutate(
dnaID = ifelse((1:n())==1 & lonely, yes=glue::glue("Fleeter{date}{measOrder}"), no=dnaID),
dnaID = ifelse(i_pit == 2 & lonely, yes=glue::glue("Fleeter{date}{measOrder}"), no=dnaID)
) %>%
ungroup() %>%
select(-lonely)
}
cycle <- function(tb_ID,tb_raw) {
tb_IDtemp <-
tb_raw %>%
select(-c(dnaID)) %>%
filter(!is.na(pit),nchar(pit)==23) %>%
datepit_to_ID2(tb_ID) %>%
pivot_wider(id_cols = c(i_measurement,date,ID), names_from = i_pit, values_from=pit) %>% group_by(i_measurement) %>% summarise_all(function(x){x[!is.na(x)][1]}) %>%
pivot_longer(-c(date,ID,i_measurement),names_to="i_pit",values_to="pit") %>%
group_by(pit,i_pit,i_measurement) %>%
summarise(
date = ymd(date[1]),
ID = ID[1]
) %>%
filter(!is.na(ID),!is.na(pit)) %>%
group_by(ID,pit) %>%
summarise_all(function(x){x[!is.na(x)][1]}) %>%
ungroup()
}
# a table with where every record of a pit tag is one row
# incl. pit, date, i_measurement, dnaID (if any), pit_i
tf_pit_raw_long <<-
tb %>%
clean_ID_df(column_name="dnaID",prefix="Offsp",numLength=4,keep_name=T,remove_NA=F) %>%
rename(
pit.1=pit,
pit.2=pit_new,
pit.3=pit_second,
pit.4=pit_third
) %>%
mutate(i_measurement = row_number()) %>%
pivot_longer(c(pit.1,pit.2,pit.3,pit.4),names_to="i_pit",values_to="pit") %>%
filter(!is.na(pit),nchar(pit)==23) %>%
identify_fleeters() %>%
select(pit, date, dnaID, i_pit,i_measurement)
# finclip matches
# keep only rows with a DNAID - and translate DNAID to ID_original
tf_pit_DNAID <-
tf_pit_raw_long %>%
filter(!is.na(dnaID), !is.na(pit)) %>%
lookup::lookup(
from = finclip_matches,
by.x = "dnaID",
by.y = "ID",
what = "ID_original",
overwrite = T,
overwriteNA = F
)
tf_pit_ID <-
tf_pit_DNAID %>%
rename(ID=dnaID) %>%
cycle(tf_pit_raw_long) %>%
cycle(tf_pit_raw_long) %>%
cycle(tf_pit_raw_long) %>%
select(pit,date,ID)
return(tf_pit_ID)
}
tb_rednaid <- tb_fish %>%
filter(period==8 | period==9) %>%
filter(!is.na(dnaID), !is.na(pit)) %>%
select(pit,pit_new,pit_second,pit_third,dnaID,date) %>%
pivot_longer(c(pit,pit_new,pit_second,pit_third),names_to="pit_i",values_to="pit") %>%
select(-pit_i) %>%
filter(!is.na(pit))
tb_finclips <- read_delim("lookup - lammisalmon fin clip matches 5.csv")
tb_datepit <- write_datepit_file(tb_fish,tb_finclips)
View(tb_datepit)
tb_datepit2 <- tb_datepit %>%
datepit::re_dnaID(tb_rednaid)
View(tb_datepit2)
#' @title re_dnaID
#' @export
re_dnaID <- function(tb,tb_rednaid){
require(glue)
#1: Go through each row in the rednaID table
#2: for the given pit, and date:
#3: find the item in the datepit table with:
#4: the same pit
#5: that was registered the time before that datepit
#6 then, rename the ID in that item with the one from the current row in the rednaID table
tb <- tb %>% clean_ID_df(column_name="dnaID",prefix="Offsp",numLength=4,keep_name=T,remove_NA=F) %>%
for( i_row in 1:nrow(tb_rednaid) )
{
row <- tb_rednaid[i_row,]
pit <- row$pit
date <- row$date
dnaid <- row$dnaID
if(nrow( tb[tb$pit==pit & tb$date < date,])==0) message(glue("re-dnaid: pit {pit} for id {dnaid} and date {date} not found"))
tb[tb$pit==pit & tb$date < date,][1,][["ID"]] <- dnaid
}
return(tb)
}
tb_datepit2 <- tb_datepit %>%
datepit::re_dnaID(tb_rednaid)
View(tb_datepit2)
View(tb_datepit)
tb_datepit2 <- tb_datepit %>%
re_dnaID(tb_rednaid)
tb_rednaid <- tb_fish %>%
filter(period==8 | period==9) %>%
filter(!is.na(dnaID), !is.na(pit)) %>%
select(pit,pit_new,pit_second,pit_third,dnaID,date) %>%
pivot_longer(c(pit,pit_new,pit_second,pit_third),names_to="pit_i",values_to="pit") %>%
select(-pit_i) %>%
filter(!is.na(pit))
#' @title re_dnaID
#' @export
re_dnaID <- function(tb,tb_rednaid){
require(glue)
#1: Go through each row in the rednaID table
#2: for the given pit, and date:
#3: find the item in the datepit table with:
#4: the same pit
#5: that was registered the time before that datepit
#6 then, rename the ID in that item with the one from the current row in the rednaID table
tb <- tb %>% clean_ID_df(column_name="dnaID",prefix="Offsp",numLength=4,keep_name=T,remove_NA=F)
for( i_row in 1:nrow(tb_rednaid) )
{
row <- tb_rednaid[i_row,]
pit <- row$pit
date <- row$date
dnaid <- row$dnaID
if(nrow( tb[tb$pit==pit & tb$date < date,])==0) message(glue("re-dnaid: pit {pit} for id {dnaid} and date {date} not found"))
tb[tb$pit==pit & tb$date < date,][1,][["ID"]] <- dnaid
}
return(tb)
}
tb_rednaid <- tb_fish %>%
filter(period==8 | period==9) %>%
filter(!is.na(dnaID), !is.na(pit)) %>%
select(pit,pit_new,pit_second,pit_third,dnaID,date) %>%
pivot_longer(c(pit,pit_new,pit_second,pit_third),names_to="pit_i",values_to="pit") %>%
select(-pit_i) %>%
filter(!is.na(pit))
tb_datepit2 <- tb_datepit %>%
re_dnaID(tb_rednaid)
#' @title re_dnaID
#' @export
re_dnaID <- function(tb,tb_rednaid){
require(glue)
#1: Go through each row in the rednaID table
#2: for the given pit, and date:
#3: find the item in the datepit table with:
#4: the same pit
#5: that was registered the time before that datepit
#6 then, rename the ID in that item with the one from the current row in the rednaID table
tb <- tb %>% clean_ID_df(column_name="dnaID",prefix="Offsp",numLength=4,keep_name=T,remove_NA=F)
for( i_row in 1:nrow(tb_rednaid) )
{
row <- tb_rednaid[i_row,]
pit <- row$pit
date <- row$date
dnaid <- row$ID
if(nrow( tb[tb$pit==pit & tb$date < date,])==0) message(glue("re-dnaid: pit {pit} for id {dnaid} and date {date} not found"))
tb[tb$pit==pit & tb$date < date,][1,][["ID"]] <- dnaid
}
return(tb)
}
tb_datepit2 <- tb_datepit %>%
re_dnaID(tb_rednaid)
tb_rednaid <- tb_rednaid %>% clean_ID_df(column_name="dnaID",prefix="Offsp",numLength=4,keep_name=T,remove_NA=F)
for( i_row in 1:nrow(tb_rednaid) )
#' @title re_dnaID
#' @export
re_dnaID <- function(tb,tb_rednaid){
require(glue)
#1: Go through each row in the rednaID table
#2: for the given pit, and date:
#3: find the item in the datepit table with:
#4: the same pit
#5: that was registered the time before that datepit
#6 then, rename the ID in that item with the one from the current row in the rednaID table
tb_rednaid <- tb_rednaid %>% clean_ID_df(column_name="dnaID",prefix="Offsp",numLength=4,keep_name=T,remove_NA=F)
for( i_row in 1:nrow(tb_rednaid) )
{
row <- tb_rednaid[i_row,]
pit <- row$pit
date <- row$date
dnaid <- row$ID
if(nrow( tb[tb$pit==pit & tb$date < date,])==0) message(glue("re-dnaid: pit {pit} for id {dnaid} and date {date} not found"))
tb[tb$pit==pit & tb$date < date,][1,][["ID"]] <- dnaid
}
return(tb)
}
tb_datepit2 <- tb_datepit %>%
re_dnaID(tb_rednaid)
tb_datepit2 <- tb_datepit %>%
re_dnaID(tb_rednaid)
#' @title re_dnaID
#' @export
re_dnaID <- function(tb,tb_rednaid){
require(glue)
#1: Go through each row in the rednaID table
#2: for the given pit, and date:
#3: find the item in the datepit table with:
#4: the same pit
#5: that was registered the time before that datepit
#6 then, rename the ID in that item with the one from the current row in the rednaID table
tb_rednaid <- tb_rednaid %>% clean_ID_df(column_name="dnaID",prefix="Offsp",numLength=4,keep_name=T,remove_NA=F)
for( i_row in 1:nrow(tb_rednaid) )
{
row <- tb_rednaid[i_row,]
pit <- row$pit
date <- row$date
dnaid <- row$dnaID
if(nrow( tb[tb$pit==pit & tb$date < date,])==0) message(glue("re-dnaid: pit {pit} for id {dnaid} and date {date} not found"))
tb[tb$pit==pit & tb$date < date,][1,][["ID"]] <- dnaid
}
return(tb)
}
tb_datepit2 <- tb_datepit %>%
re_dnaID(tb_rednaid)
View(tb_datepit2)
setwd(dirname(rstudioapi::getActiveDocumentContext()$path))
devtools::document()
setwd("C:/Users/asheimer/files/Jottacloud/github/datepit")
devtools::document()
devtools::install_github("eiriksen/eiriktools")
devtools::install_github("eiriksen/datepit")
devtools::install_github("eiriksen/lookup")
library(lubridate)
library(tidyverse)
library(lammidrive) # devtools::install_github("eiriksen/lammidrive")
library(datepit) # devtools::install_github("eiriksen/datepit")
library(eiriktools) # devtools::install_github("eiriksen/eiriktools")
library(glue)
library(lookup) # devtools::install_github("eiriksen/lookup")
.version="v2"
.month="Feb2022"
tb_fish <-
eiriktools::read_delim_multi(
list_filepaths =list.files(pattern="pheno-P\\d.*txt",recursive=T),
col_types = list(
id              = col_integer(),
mature_female   = col_character(),
dnaID           = col_character(),
ID_fem          = col_character(),
weight_postEggs = col_number(),
cataracts       = col_number(),
mature          = col_number(),
parr            = col_number(),
kype            = col_number()
)
) %>%
mutate(pit = toupper(pit)) %>%
lookup::lookup(
read_delim("data - eggs/2020 egg sampling data/data - lammi_mature_female_and_egg_2020.csv"),
by.x = c("pit","date"),
by.y = c("PIT","date"),
what = "PIT_new",
new_name = "pit_new"
) %>%
lookup::lookup(
read_delim("data - eggs/2021 egg sampling data/raw data - lammi_mature_female_and_egg_2021.csv"),
by.x = c("pit","date"),
by.y = c("pit","date_meas"),
what = "new_pit",
new_name = "pit_new"
)
setwd("C:/Users/asheimer/files/Drive/delte prosjekter/Lammi salmon/Project Big Tanks")
tb_fish <-
eiriktools::read_delim_multi(
list_filepaths =list.files(pattern="pheno-P\\d.*txt",recursive=T),
col_types = list(
id              = col_integer(),
mature_female   = col_character(),
dnaID           = col_character(),
ID_fem          = col_character(),
weight_postEggs = col_number(),
cataracts       = col_number(),
mature          = col_number(),
parr            = col_number(),
kype            = col_number()
)
) %>%
mutate(pit = toupper(pit)) %>%
lookup::lookup(
read_delim("data - eggs/2020 egg sampling data/data - lammi_mature_female_and_egg_2020.csv"),
by.x = c("pit","date"),
by.y = c("PIT","date"),
what = "PIT_new",
new_name = "pit_new"
) %>%
lookup::lookup(
read_delim("data - eggs/2021 egg sampling data/raw data - lammi_mature_female_and_egg_2021.csv"),
by.x = c("pit","date"),
by.y = c("pit","date_meas"),
what = "new_pit",
new_name = "pit_new"
)
tb_fish <-
eiriktools::read_delim_multi(
list_filepaths =list.files(pattern="pheno-P\\d.*txt",recursive=T),
col_types = list(
id              = col_integer(),
mature_female   = col_character(),
dnaID           = col_character(),
ID_fem          = col_character(),
weight_postEggs = col_number(),
cataracts       = col_number(),
mature          = col_number(),
parr            = col_number(),
kype            = col_number()
)
) %>%
mutate(pit = toupper(pit)) %>%
lookup::lookup(
read_delim("data - eggs/2020 egg sampling data/data - lammi_mature_female_and_egg_2020.csv"),
by.x = c("pit","date"),
by.y = c("PIT","date"),
what = "PIT_new",
new_name = "pit_new",
default=""
) %>%
lookup::lookup(
read_delim("data - eggs/2021 egg sampling data/raw data - lammi_mature_female_and_egg_2021.csv"),
by.x = c("pit","date"),
by.y = c("pit","date_meas"),
what = "new_pit",
new_name = "pit_new",
default=""
)
warnings()
tb_rednaid <- tb_fish %>%
filter(period==8 | period==9) %>%
filter(!is.na(dnaID), !is.na(pit)) %>%
select(pit,pit_new,pit_second,pit_third,dnaID,date) %>%
pivot_longer(c(pit,pit_new,pit_second,pit_third),names_to="pit_i",values_to="pit") %>%
select(-pit_i) %>%
filter(!is.na(pit))
tb_finclips <- read_delim("lookup - lammisalmon fin clip matches 5.csv")
tb_datepit <- datepit::write_datepit_file(tb_fish,tb_finclips) %>%
datepit::re_dnaID(tb_rednaid)
# devtools::install_github("eiriksen/datepit")
devtools::install_github("eiriksen/datepit")
library(datepit) # devtools::install_github("eiriksen/datepit")
View(write_datepit_file)
tb_datepit <- datepit::write_datepit_file(tb_fish,tb_finclips) %>%
datepit::re_dnaID(tb_rednaid)
library(lubridate)
library(tidyverse)
library(lammidrive) # devtools::install_github("eiriksen/lammidrive")
library(datepit) # devtools::install_github("eiriksen/datepit")
library(eiriktools) # devtools::install_github("eiriksen/eiriktools")
library(glue)
library(lookup) # devtools::install_github("eiriksen/lookup")
.version="v2"
.month="Feb2022"
tb_fish <-
eiriktools::read_delim_multi(
list_filepaths =list.files(pattern="pheno-P\\d.*txt",recursive=T),
col_types = list(
id              = col_integer(),
mature_female   = col_character(),
dnaID           = col_character(),
ID_fem          = col_character(),
weight_postEggs = col_number(),
cataracts       = col_number(),
mature          = col_number(),
parr            = col_number(),
kype            = col_number()
)
) %>%
mutate(pit = toupper(pit)) %>%
lookup::lookup(
read_delim("data - eggs/2020 egg sampling data/data - lammi_mature_female_and_egg_2020.csv"),
by.x = c("pit","date"),
by.y = c("PIT","date"),
what = "PIT_new",
new_name = "pit_new",
default=""
) %>%
lookup::lookup(
read_delim("data - eggs/2021 egg sampling data/raw data - lammi_mature_female_and_egg_2021.csv"),
by.x = c("pit","date"),
by.y = c("pit","date_meas"),
what = "new_pit",
new_name = "pit_new",
default=""
)
tb_rednaid <- tb_fish %>%
filter(period==8 | period==9) %>%
filter(!is.na(dnaID), !is.na(pit)) %>%
select(pit,pit_new,pit_second,pit_third,dnaID,date) %>%
pivot_longer(c(pit,pit_new,pit_second,pit_third),names_to="pit_i",values_to="pit") %>%
select(-pit_i) %>%
filter(!is.na(pit))
tb_finclips <- read_delim("lookup - lammisalmon fin clip matches 5.csv")
tb_datepit <- datepit::write_datepit_file(tb_fish,tb_finclips) %>%
datepit::re_dnaID(tb_rednaid)
write_delim(
tb_datepit,
glue::glue("lookup-pit-to-ID-{.month}-{.version}.txt")
)
parse_date_time("02-02-22")
lubridate::parse_date_time("02-02-22")
lubridate::parse_date_time("02-02-22",c("ymd","dmy"))
lubridate::parse_date_time("22-02-22",c("ymd","dmy"))
lubridate::parse_date_time(c("02-02-22","22-02-02"),c("ymd","dmy"))
typeof(ymd("02-02-22"))
typeof(lubridate::ymd("02-02-22"))
is.Date("02-02-22")
lubridate::is.Date("02-02-22")
lubridate::is.Date(dmy("02-02-22"))
lubridate::is.Date(lubridate::dmy("02-02-22"))
setwd(dirname(rstudioapi::getActiveDocumentContext()$path))
devtools::document()
setwd("G:/.shortcut-targets-by-id/1DXAvQYtRSS3l3vODEIEnoYkFD4GfDr9k/Lammi salmon/Project Big Tanks/9 - feb 2021")
library(tidyverse)
library(lubridate)
library(eiriktools) # devtools::install_github("eiriksen/eiriktools")
library(lookup) # devtools::install_github("eiriksen/lookup")
tb_fish <-
read_delim("raw data - feb 2021 - phenotype.txt") %>%
merge(
read_delim("raw data - feb 2021 - secondary.txt"),
by="measOrder"
) %>%
mutate(
weight = eiriktools::numextract(weight),
length = eiriktools::numextract(length),
mature_female = as.character(mature_female),
ID_fem = as.character(ID_fem),
date = dmy(date),
temp = recode(tank,
"T21"="hot","T22"="cold","T23"="hot","T24"="cold","T25"="hot","T26"="cold",
"T27"="hot", "T28"="cold","T29"="hot","T30"="cold","T31"="hot","T32"="cold"
),
feed = recode(tank,
"T21"="LF","T22"="HF","T23"="LF","T24"="LF","T25"="HF","T26"="LF",
"T27"="HF","T28"="LF","T29"="HF","T30"="HF","T31"="LF","T32"="HF"
)
) %>%
mutate(period=9) %>%
eiriktools::duplicates_cut_adv()
# Fill in some missing PIT-tags recovered by detective-work:
#3677 is A0000000900226000410851 (Later found not, 851 is still swimming in the tank)
#3698 is A0000000900226000994473
#3106 is A0000000900226000332726
#tb_fish[tb_fish$measOrder==3677,]$pit="A0000000900226000410851"
tb_fish[tb_fish$measOrder==3698,]$pit="A0000000900226000994473"
tb_fish[tb_fish$measOrder==3106,]$pit="A0000000900226000332726"
# this one needs a fin clip,
tb_fish[tb_fish$measOrder=="3677",]$dnaID = "need_finclip_1"
# row 2250 is not a fish
tb_fish <- tb_fish %>% filter(measOrder!=2250)
# duplicated pit tags (none)
eiriktools::duplicates_find(df_fish, by="pit")
# Remove PIT's that are not PIT's
tb_fish <- tb_fish %>% mutate(pit=ifelse(nchar(pit) != 23, NA,pit))
# save
tb_fish %>% write_delim("data-lammisalmon-pheno-P9-feb2020.txt")