# Xiaofeng Xu created this file in May 2020, and updated in Sep 2020, and finalized with 14C on Nov 11 2020
library("RNetCDF")
library("akima")
rm(list=ls())
setwd("/Users/xxuadmin/BUSINESS/PUBLICATIONS/WorkingOn_Xu_Isotope/SPRUCE_2020Sep")
# 13C is based on the PD standard Pee Dee Belemnite (PDB). 13C:12C = 0.0112372.
# 13C/12C(sample) / 13C/12C(standard - 1)
# 13C = (delta / 1000 + 1) * 0.0112372 * 12C

# for the spruce site, the 14C = 12C * ((1 + delta14C / 1000) * (1.176e-12/((1+delta13C)*(1+delta13C)/(1-0.025)/(1-0.025)))
# the 13Cdealta is -25 per mil for standard sample; this is for SPRUCE site based on the data from Erik Hobbie at UNH

data <- read.csv("Peat_Characteristics_T0_20180425_plot.csv", header=TRUE)
O13C <- data[1:16,3:4]
O14C <- data[1:16,5]
#depth 25, 15, 5, -5, -25, -35, -45, -55, -65, -85, -113, -163, -188, -225, -255
#CLM depth 0.71, 2.8, 6.2, 11.9, 21.2, 36.6, 61.97, 103.8, 172.8, 286.5, 473.9, 782.97, 1292.5, 2132.6, 3517.8

depth <- c(0.0071, 0.0028, 0.0623, 0.1189, 0.2122, 0.366, 0.6197, 1.038, 1.72, 2.86)

#Hommock
#25 for layer 1, 2, 3
#15 for layer 4
# 5 for layer 5,
#-5 for layer 6,
#-25, -35, -45 for layer 7
#-55, -65, and -85 for layer 8
# -113, -163, and -188 for layer 9
# -255 for layer 10 2.86

#Hollow
#-5 for layer 1, 2, 3
# -15 for layer 4,
#-25 for layer 5,
#-35 for layer 6
#-45 -55, and -65 for layer 7 0.6197
#-85 and -133 for layer 8 1.038
# -163 and -188 for layer 9 1.72
# -225 and -275 for layer 10 2.86
SO13C = array(0, dim=c(15,2))
#L13C = O13C[3,1]
SO13C[1,1] = O13C[1,1]
SO13C[2,1] = O13C[1,1]
SO13C[3,1] = O13C[1,1]
SO13C[4,1] = O13C[2,1]
SO13C[5,1] = O13C[3,1]
SO13C[6,1] = O13C[4,1]
SO13C[7,1] = mean(O13C[5:7,1])
SO13C[8,1] = mean(O13C[8:10,1])
SO13C[9,1] = mean(O13C[11:13,1])
SO13C[10,1] = mean(O13C[14:15,1])

SO13C[1,2] = mean(O13C[3:4,1])
SO13C[2,2] = mean(O13C[3:4,1])
SO13C[3,2] = mean(O13C[3:4,1])
SO13C[4,2] = mean(O13C[4:5,1])
SO13C[5,2] = mean(O13C[6:7,1])
SO13C[6,2] = mean(O13C[8:9,1])
SO13C[7,2] = mean(O13C[8:9,1])
SO13C[8,2] = mean(O13C[10:11,1])
SO13C[9,2] = mean(O13C[12:13,1])
SO13C[10,2] = mean(O13C[14:16,1])

#plot(SO13C[1:10,1],-depth,type="l",xlab="soil 13CH4 (mmol/L)", ylab="soil depth (m)",cex=1,las=1, cex.lab = 1.5, cex.axis = 1.5,lwd=2)

SO14C = array(0, dim=c(15,2))
SO14C[1,1] = O14C[1]
SO14C[2,1] = O14C[1]
SO14C[3,1] = O14C[1]
SO14C[4,1] = O14C[2]
SO14C[5,1] = O14C[3]
SO14C[6,1] = O14C[4]
SO14C[7,1] = mean(O14C[5:7])
SO14C[8,1] = mean(O14C[8:10])
SO14C[9,1] = mean(O14C[11:13])
SO14C[10,1] = mean(O14C[14:15])

SO14C[1,2] = O14C[4]
SO14C[2,2] = O14C[4]
SO14C[3,2] = O14C[4]
SO14C[4,2] = O14C[5]
SO14C[5,2] = O14C[6]
SO14C[6,2] = mean(O14C[7:9])
SO14C[7,2] = mean(O14C[7:9])
SO14C[8,2] = mean(O14C[10:11])
SO14C[9,2] = mean(O14C[12:13])
SO14C[10,2] = mean(O14C[14:16])

#13C_ave	Depth_ave
#-29.058	25
#-28.34	15
#-28.1075	5
#-28.77631579	-5
#-27.79684211	-15
#-27.006	-25
#-26.72888889	-35
#-26.45055556	-45
#-26.60555556	-55
#-26.36611111	-65
#-26.05333333	-85
#-25.93	-113
#-26.39176471	-163
#-26.27	-188
#-26.63857143	-225
#-25.75	-275

#depth	14C_mean	14Cto12C
#25	40.65714286	1.23406E-12
#15	54.37692308	1.24849E-12
#5	112.4714286	1.31665E-12
#-5	68.17647059	1.26596E-12
#-15	140.0176471	1.34839E-12
#-25	114.2	        1.31571E-12
#-35	-99.17647059	1.06314E-12
#-45	-180.2058824	9.66953E-13
#-55	-199.9941176	9.43913E-13
#-65	-286.2058824	8.41779E-13
#-85	-358.8117647	7.55669E-13
#-113	-392.4058824	7.15896E-13
#-163	-486.13125	6.06039E-13
#-188	-350.8	        7.65452E-13
#-225	-571.1	        5.06086E-13
#-275	-703.75	        3.48927E-13

computC13 <- function(C12, deltaC)
{
        (deltaC / 1000.0 + 1.0) * 0.0112372 * C12
}

computC14 <- function(C12, deltaC13, deltaC14)
{
        C12 * ((1.0 + deltaC14 / 1000) * (1.176e-12/((1+deltaC13)*(1+deltaC13)/(1-0.000025)/(1-0.000025))))
}

#14C = 12C * ((1 + delta14C / 1000) * (1.176e-12/((1+delta13C)*(1+delta13C)/(1-0.025)/(1-0.025)))

#notice: please copy a file with the name of fileoutput in the following code for variable to be incorporated
fileinput <- open.nc("SPRUCE-finalspinup-peatland-carbon-initial.nc")  # 2012 year climate data
#filerestart <- open.nc("SPR_I20TRCLM45CN_adspinup.clm2.r.1201-01-01-00000.nc")
fileoutput <- open.nc("SPRUCE-finalspinup-peatland-ISOcarbon-initial.nc",write=TRUE)

#depth <- c(0.0071, 0.0028, 0.0623, 0.1189, 0.2122, 0.366, 0.6197, 1.038, 1.72, 2.86)
#thick <- c(0.0175128179, 0.0275789693, 0.0454700332, 0.0749674110, 0.1236003651, 0.2037825510, 0.3359806264, 0.5539384054, 0.9132900316, 1.5057607014)
#realcarbondensity = c(22385, 22385, 22385, 30294, 43978, 95584, 92983, 83658, 83799, 90616)

cwdc_vr <- var.get.nc(fileinput, "cwdc_vr")
litr1c_vr <- var.get.nc(fileinput, "litr1c_vr")
litr2c_vr <- var.get.nc(fileinput, "litr2c_vr")
litr3c_vr <- var.get.nc(fileinput, "litr3c_vr")
soil1c_vr <- var.get.nc(fileinput, "soil1c_vr")
soil2c_vr <- var.get.nc(fileinput, "soil2c_vr")
soil3c_vr <- var.get.nc(fileinput, "soil3c_vr")
soil4c_vr <- var.get.nc(fileinput, "soil4c_vr")

cwdn_vr <- var.get.nc(fileinput, "cwdn_vr")
litr1n_vr <- var.get.nc(fileinput, "litr1c_vr")
litr2n_vr <- var.get.nc(fileinput, "litr2n_vr")
litr3n_vr <- var.get.nc(fileinput, "litr3n_vr")
soil1n_vr <- var.get.nc(fileinput, "soil1n_vr")
soil2n_vr <- var.get.nc(fileinput, "soil2n_vr")
soil3n_vr <- var.get.nc(fileinput, "soil3n_vr")
soil4n_vr <- var.get.nc(fileinput, "soil4n_vr")

#rc13_canair <- var.get.nc(filerestart, "rc13_canair")
#rc13_psnsun <- var.get.nc(filerestart, "rc13_psnsun")
#rc13_psnsha <- var.get.nc(filerestart, "rc13_psnsha")
#leafc_13 <- var.get.nc(filerestart, "leafc_13")
#leafc_storage_13 <- var.get.nc(filerestart, "leafc_storage_13")
#leafc_xfer_13 <- var.get.nc(filerestart, "leafc_xfer_13")
#frootc_13 <- var.get.nc(filerestart, "frootc_13")
#frootc_storage_13 <- var.get.nc(filerestart, "frootc_storage_13")
#frootc_xfer_13 <- var.get.nc(filerestart, "frootc_xfer_13")
#livestemc_13 <- var.get.nc(filerestart, "livestemc_13")
#livestemc_storage_13 <- var.get.nc(filerestart, "livestemc_storage_13")
#livestemc_xfer_13 <- var.get.nc(filerestart, "livestemc_xfer_13")
#deadstemc_13 <- var.get.nc(filerestart, "deadstemc_13")
#deadstemc_storage_13 <- var.get.nc(filerestart, "deadstemc_storage_13")
#deadstemc_xfer_13 <- var.get.nc(filerestart, "deadstemc_xfer_13")
#livecrootc_13 <- var.get.nc(filerestart, "livecrootc_13")
#deadstemc_13 <- var.get.nc(filerestart, "deadstemc_13")

cwdc_13_vr = cwdc_vr
litr1c_13_vr = litr1c_vr
litr2c_13_vr = litr2c_vr
litr3c_13_vr = litr3c_vr
soil1c_13_vr = soil1c_vr
soil2c_13_vr = soil2c_vr
soil3c_13_vr = soil3c_vr
soil4c_13_vr = soil4c_vr

# C14
cwdc_14_vr = cwdc_vr
litr1c_14_vr = litr1c_vr
litr2c_14_vr = litr2c_vr
litr3c_14_vr = litr3c_vr
soil1c_14_vr = soil1c_vr
soil2c_14_vr = soil2c_vr
soil3c_14_vr = soil3c_vr
soil4c_14_vr = soil4c_vr

bacteriac_vr = litr1c_vr
fungic_vr = litr1c_vr
domc_vr = litr1c_vr
seedc = litr1c_vr
col_ctrunc_vr = litr1c_vr

totlitc = litr1c_vr
totcolc = litr1c_vr
prod10c = litr1c_vr
prod100c = litr1c_vr

bacteriac_13_vr = bacteriac_vr
fungic_13_vr = fungic_vr
domc_13_vr = domc_vr
seedc_13 = seedc
col_ctrunc_13_vr = col_ctrunc_vr

totlitc_13 = totlitc
totcolc_13 = totcolc
prod10c_13 = prod10c
prod100c_13 = prod100c

#C14
bacteriac_14_vr = bacteriac_vr
fungic_14_vr = fungic_vr
domc_14_vr = domc_vr
seedc_14 = seedc
col_ctrunc_14_vr = col_ctrunc_vr

totlitc_14 = totlitc
totcolc_14 = totcolc
prod10c_14 = prod10c
prod100c_14 = prod100c

for(i in 1:10)
{
cwdc_13_vr[i,1] = computC13(cwdc_vr[i,1], SO13C[i])
litr1c_13_vr[i,1] = computC13(litr1c_vr[i,1], SO13C[i])
litr2c_13_vr[i,1] = computC13(litr2c_vr[i,1], SO13C[i])
litr3c_13_vr[i,1] = computC13(litr3c_vr[i,1], SO13C[i])
soil1c_13_vr[i,1] = computC13(soil1c_vr[i,1], SO13C[i])
soil2c_13_vr[i,1] = computC13(soil2c_vr[i,1], SO13C[i])
soil3c_13_vr[i,1] = computC13(soil3c_vr[i,1], SO13C[i])
soil4c_13_vr[i,1] = computC13(soil4c_vr[i,1], SO13C[i])

bacteriac_13_vr[i,1] = computC13(bacteriac_vr[i,1], SO13C[i])
fungic_13_vr[i,1] = computC13(fungic_vr[i,1], SO13C[i])
domc_13_vr[i,1] = computC13(domc_vr[i,1], SO13C[i])
seedc_13[i,1] = computC13(seedc[i,1], SO13C[i])
col_ctrunc_13_vr[i,1] = computC13(col_ctrunc_vr[i,1], SO13C[i])
totlitc_13[i,1] = computC13(totlitc[i,1], SO13C[i])
totcolc_13[i,1] = computC13(totcolc[i,1], SO13C[i])
prod10c_13[i,1] = computC13(prod10c[i,1], SO13C[i])
prod100c_13[i,1] = computC13(prod100c[i,1], SO13C[i])

cwdc_13_vr[i,2] = computC13(cwdc_vr[i,2], SO13C[i])
litr1c_13_vr[i,2] = computC13(litr1c_vr[i,2], SO13C[i])
litr2c_13_vr[i,2] = computC13(litr2c_vr[i,2], SO13C[i])
litr3c_13_vr[i,2] = computC13(litr3c_vr[i,2], SO13C[i])
soil1c_13_vr[i,2] = computC13(soil1c_vr[i,2], SO13C[i])
soil2c_13_vr[i,2] = computC13(soil2c_vr[i,2], SO13C[i])
soil3c_13_vr[i,2] = computC13(soil3c_vr[i,2], SO13C[i])
soil4c_13_vr[i,2] = computC13(soil4c_vr[i,2], SO13C[i])

bacteriac_13_vr[i,2] = computC13(bacteriac_vr[i,2], SO13C[i])
fungic_13_vr[i,2] = computC13(fungic_vr[i,2], SO13C[i])
domc_13_vr[i,2] = computC13(domc_vr[i,2], SO13C[i])
seedc_13[i,2] = computC13(seedc[i,2], SO13C[i])
col_ctrunc_13_vr[i,2] = computC13(col_ctrunc_vr[i,2], SO13C[i])
totlitc_13[i,2] = computC13(totlitc[i,2], SO13C[i])
totcolc_13[i,2] = computC13(totcolc[i,2], SO13C[i])
prod10c_13[i,2] = computC13(prod10c[i,2], SO13C[i])
prod100c_13[i,2] = computC13(prod100c[i,2], SO13C[i])
}

for(i in 11:15)
{
cwdc_13_vr[i,1] = 0.0
litr1c_13_vr[i,1] = 0.0
litr2c_13_vr[i,1] = 0.0
litr3c_13_vr[i,1] = 0.0
soil1c_13_vr[i,1] = 0.0
soil2c_13_vr[i,1] = 0.0
soil3c_13_vr[i,1] = 0.0
soil4c_13_vr[i,1] = 0.0

bacteriac_13_vr[i,1] = 0.0
fungic_13_vr[i,1] = 0.0
domc_13_vr[i,1] = 0.0
seedc_13[i,1] = 0.0
col_ctrunc_13_vr[i,1] = 0.0

totlitc_13[i,1] = 0.0
totcolc_13[i,1] = 0.0
prod10c_13[i,1] = 0.0
prod100c_13[i,1] = 0.0

cwdc_13_vr[i,2] = 0.0
litr1c_13_vr[i,2] = 0.0
litr2c_13_vr[i,2] = 0.0
litr3c_13_vr[i,2] = 0.0
soil1c_13_vr[i,2] = 0.0
soil2c_13_vr[i,2] = 0.0
soil3c_13_vr[i,2] = 0.0
soil4c_13_vr[i,2] = 0.0

bacteriac_13_vr[i,2] = 0.0
fungic_13_vr[i,2] = 0.0
domc_13_vr[i,2] = 0.0
seedc_13[i,2] = 0.0
col_ctrunc_13_vr[i,2] = 0.0

totlitc_13[i,2] = 0.0
totcolc_13[i,2] = 0.0
prod10c_13[i,2] = 0.0
prod100c_13[i,2] = 0.0
}

for(i in 1:10)
{
        cwdc_14_vr[i,1] = computC14(cwdc_vr[i,1], cwdc_13_vr[i,1], SO14C[i])
        litr1c_14_vr[i,1] = computC14(litr1c_vr[i,1], litr1c_13_vr[i,1], SO14C[i])
        litr2c_14_vr[i,1] = computC14(litr2c_vr[i,1], litr2c_13_vr[i,1], SO14C[i])
        litr3c_14_vr[i,1] = computC14(litr3c_vr[i,1], litr3c_13_vr[i,1], SO14C[i])
        soil1c_14_vr[i,1] = computC14(soil1c_vr[i,1], soil1c_13_vr[i,1], SO14C[i])
        soil2c_14_vr[i,1] = computC14(soil2c_vr[i,1], soil2c_13_vr[i,1], SO14C[i])
        soil3c_14_vr[i,1] = computC14(soil3c_vr[i,1], soil3c_13_vr[i,1], SO14C[i])
        soil4c_14_vr[i,1] = computC14(soil4c_vr[i,1], soil4c_13_vr[i,1], SO14C[i])

        bacteriac_14_vr[i,1] = computC14(bacteriac_vr[i,1], bacteriac_13_vr[i,1], SO14C[i])
        fungic_14_vr[i,1] = computC14(fungic_vr[i,1], fungic_13_vr[i,1], SO14C[i])
        domc_14_vr[i,1] = computC14(domc_vr[i,1], domc_13_vr[i,1], SO14C[i])
        seedc_14[i,1] = computC14(seedc[i,1], seedc_13[i,1], SO14C[i])
        col_ctrunc_14_vr[i,1] = computC14(col_ctrunc_vr[i,1], col_ctrunc_13_vr[i,1], SO14C[i])
        totlitc_14[i,1] = computC14(totlitc[i,1], totlitc_13[i,1], SO14C[i])
        totcolc_14[i,1] = computC14(totcolc[i,1], totcolc_13[i,1], SO14C[i])
        prod10c_14[i,1] = computC14(prod10c[i,1], prod10c_13[i,1], SO14C[i])
        prod100c_14[i,1] = computC14(prod100c[i,1], prod100c_13[i,1], SO14C[i])

        cwdc_14_vr[i,2] = computC14(cwdc_vr[i,2], cwdc_13_vr[i,2], SO14C[i])
        litr1c_14_vr[i,2] = computC14(litr1c_vr[i,2], litr1c_13_vr[i,2], SO14C[i])
        litr2c_14_vr[i,2] = computC14(litr2c_vr[i,2], litr2c_13_vr[i,2], SO14C[i])
        litr3c_14_vr[i,2] = computC14(litr3c_vr[i,2], litr3c_13_vr[i,2], SO14C[i])
        soil1c_14_vr[i,2] = computC14(soil1c_vr[i,2], soil1c_13_vr[i,2], SO14C[i])
        soil2c_14_vr[i,2] = computC14(soil2c_vr[i,2], soil2c_13_vr[i,2], SO14C[i])
        soil3c_14_vr[i,2] = computC14(soil3c_vr[i,2], soil3c_13_vr[i,2], SO14C[i])
        soil4c_14_vr[i,2] = computC14(soil4c_vr[i,2], soil4c_13_vr[i,2], SO14C[i])

        bacteriac_14_vr[i,2] = computC14(bacteriac_vr[i,2], bacteriac_13_vr[i,2], SO14C[i])
        fungic_14_vr[i,2] = computC14(fungic_vr[i,2], fungic_13_vr[i,2], SO14C[i])
        domc_14_vr[i,2] = computC14(domc_vr[i,2], domc_13_vr[i,2], SO14C[i])
        seedc_14[i,2] = computC14(seedc[i,2], seedc_13[i,2], SO14C[i])
        col_ctrunc_14_vr[i,2] = computC14(col_ctrunc_vr[i,2], col_ctrunc_13_vr[i,2], SO14C[i])
        totlitc_14[i,2] = computC14(totlitc[i,2], totlitc_13[i,2], SO14C[i])
        totcolc_14[i,2] = computC14(totcolc[i,2], totcolc_13[i,2], SO14C[i])
        prod10c_14[i,2] = computC14(prod10c[i,2], prod10c_13[i,2], SO14C[i])
        prod100c_14[i,2] = computC14(prod100c[i,2], prod100c_13[i,2], SO14C[i])
}

for(i in 11:15)
{
        cwdc_14_vr[i,1] = 0.0
        litr1c_14_vr[i,1] = 0.0
        litr2c_14_vr[i,1] = 0.0
        litr3c_14_vr[i,1] = 0.0
        soil1c_14_vr[i,1] = 0.0
        soil2c_14_vr[i,1] = 0.0
        soil3c_14_vr[i,1] = 0.0
        soil4c_14_vr[i,1] = 0.0

        bacteriac_14_vr[i,1] = 0.0
        fungic_14_vr[i,1] = 0.0
        domc_14_vr[i,1] = 0.0
        seedc_14[i,1] = 0.0
        col_ctrunc_14_vr[i,1] = 0.0

        totlitc_14[i,1] = 0.0
        totcolc_14[i,1] = 0.0
        prod10c_14[i,1] = 0.0
        prod100c_14[i,1] = 0.0

        cwdc_14_vr[i,2] = 0.0
        litr1c_14_vr[i,2] = 0.0
        litr2c_14_vr[i,2] = 0.0
        litr3c_14_vr[i,2] = 0.0
        soil1c_14_vr[i,2] = 0.0
        soil2c_14_vr[i,2] = 0.0
        soil3c_14_vr[i,2] = 0.0
        soil4c_14_vr[i,2] = 0.0

        bacteriac_14_vr[i,2] = 0.0
        fungic_14_vr[i,2] = 0.0
        domc_14_vr[i,2] = 0.0
        seedc_14[i,2] = 0.0
        col_ctrunc_14_vr[i,2] = 0.0

        totlitc_14[i,2] = 0.0
        totcolc_14[i,2] = 0.0
        prod10c_14[i,2] = 0.0
        prod100c_14[i,2] = 0.0
}

#
#rc13_canair = c(0.005582864, 0.002791432)
#rc13_psnsha = c(0.005544063, 0.002771556)
#rc13_psnsun = c(0.0055442, 0.002771556)
#

#levgrnd = 15
#column = 2
#var.def.nc(fileoutput,"levgrnd","NC_FLOAT","levgrnd")
#var.def.nc(fileoutput,"column","NC_FLOAT","column")

var.def.nc(fileoutput,"cwdc_13_vr","NC_FLOAT",c("levgrnd","column"))
var.def.nc(fileoutput,"litr1c_13_vr","NC_FLOAT",c("levgrnd","column"))
var.def.nc(fileoutput,"litr2c_13_vr","NC_FLOAT",c("levgrnd","column"))
var.def.nc(fileoutput,"litr3c_13_vr","NC_FLOAT",c("levgrnd","column"))
var.def.nc(fileoutput,"soil1c_13_vr","NC_FLOAT",c("levgrnd","column"))
var.def.nc(fileoutput,"soil2c_13_vr","NC_FLOAT",c("levgrnd","column"))
var.def.nc(fileoutput,"soil3c_13_vr","NC_FLOAT",c("levgrnd","column"))
var.def.nc(fileoutput,"soil4c_13_vr","NC_FLOAT",c("levgrnd","column"))
var.def.nc(fileoutput,"bacteriac_13_vr","NC_FLOAT",c("levgrnd","column"))
var.def.nc(fileoutput,"fungic_13_vr","NC_FLOAT",c("levgrnd","column"))
var.def.nc(fileoutput,"domc_13_vr","NC_FLOAT",c("levgrnd","column"))
var.def.nc(fileoutput,"seedc_13","NC_FLOAT",c("levgrnd","column"))
var.def.nc(fileoutput,"col_ctrunc_13_vr","NC_FLOAT",c("levgrnd","column"))
var.def.nc(fileoutput,"totlitc_13","NC_FLOAT",c("levgrnd","column"))
var.def.nc(fileoutput,"totcolc_13","NC_FLOAT",c("levgrnd","column"))
var.def.nc(fileoutput,"prod10c_13","NC_FLOAT",c("levgrnd","column"))
var.def.nc(fileoutput,"prod100c_13","NC_FLOAT",c("levgrnd","column"))

var.def.nc(fileoutput,"cwdc_14_vr","NC_FLOAT",c("levgrnd","column"))
var.def.nc(fileoutput,"litr1c_14_vr","NC_FLOAT",c("levgrnd","column"))
var.def.nc(fileoutput,"litr2c_14_vr","NC_FLOAT",c("levgrnd","column"))
var.def.nc(fileoutput,"litr3c_14_vr","NC_FLOAT",c("levgrnd","column"))
var.def.nc(fileoutput,"soil1c_14_vr","NC_FLOAT",c("levgrnd","column"))
var.def.nc(fileoutput,"soil2c_14_vr","NC_FLOAT",c("levgrnd","column"))
var.def.nc(fileoutput,"soil3c_14_vr","NC_FLOAT",c("levgrnd","column"))
var.def.nc(fileoutput,"soil4c_14_vr","NC_FLOAT",c("levgrnd","column"))
var.def.nc(fileoutput,"bacteriac_14_vr","NC_FLOAT",c("levgrnd","column"))
var.def.nc(fileoutput,"fungic_14_vr","NC_FLOAT",c("levgrnd","column"))
var.def.nc(fileoutput,"domc_14_vr","NC_FLOAT",c("levgrnd","column"))
var.def.nc(fileoutput,"seedc_14","NC_FLOAT",c("levgrnd","column"))
var.def.nc(fileoutput,"col_ctrunc_14_vr","NC_FLOAT",c("levgrnd","column"))
var.def.nc(fileoutput,"totlitc_14","NC_FLOAT",c("levgrnd","column"))
var.def.nc(fileoutput,"totcolc_14","NC_FLOAT",c("levgrnd","column"))
var.def.nc(fileoutput,"prod10c_14","NC_FLOAT",c("levgrnd","column"))
var.def.nc(fileoutput,"prod100c_14","NC_FLOAT",c("levgrnd","column"))

var.put.nc(fileoutput, "cwdc_vr",cwdc_vr)
var.put.nc(fileoutput, "litr1c_vr",litr1c_vr)
var.put.nc(fileoutput, "litr2c_vr",litr2c_vr)
var.put.nc(fileoutput, "litr3c_vr",litr3c_vr)
var.put.nc(fileoutput, "soil1c_vr",soil1c_vr)
var.put.nc(fileoutput, "soil2c_vr",soil2c_vr)
var.put.nc(fileoutput, "soil3c_vr",soil3c_vr)
var.put.nc(fileoutput, "soil4c_vr",soil4c_vr)

var.put.nc(fileoutput, "cwdn_vr",cwdn_vr)
var.put.nc(fileoutput, "litr1n_vr",litr1n_vr)
var.put.nc(fileoutput, "litr2n_vr",litr2n_vr)
var.put.nc(fileoutput, "litr3n_vr",litr3n_vr)
var.put.nc(fileoutput, "soil1n_vr",soil1n_vr)
var.put.nc(fileoutput, "soil2n_vr",soil2n_vr)
var.put.nc(fileoutput, "soil3n_vr",soil3n_vr)
var.put.nc(fileoutput, "soil4n_vr",soil4n_vr)

att.put.nc(fileoutput, "cwdc_13_vr","missing_value", "NC_FLOAT", -9999)
var.put.nc(fileoutput, "cwdc_13_vr",cwdc_13_vr)

att.put.nc(fileoutput, "litr1c_13_vr","missing_value", "NC_FLOAT", -9999)
var.put.nc(fileoutput, "litr1c_13_vr",litr1c_13_vr)

att.put.nc(fileoutput, "litr2c_13_vr","missing_value", "NC_FLOAT", -9999)
var.put.nc(fileoutput, "litr2c_13_vr",litr2c_13_vr)

att.put.nc(fileoutput, "litr3c_13_vr","missing_value", "NC_FLOAT", -9999)
var.put.nc(fileoutput, "litr3c_13_vr",litr3c_13_vr)

att.put.nc(fileoutput, "soil1c_13_vr","missing_value", "NC_FLOAT", -9999)
var.put.nc(fileoutput, "soil1c_13_vr",soil1c_13_vr)

att.put.nc(fileoutput, "soil2c_13_vr","missing_value", "NC_FLOAT", -9999)
var.put.nc(fileoutput, "soil2c_13_vr",soil2c_13_vr)

att.put.nc(fileoutput, "soil3c_13_vr","missing_value", "NC_FLOAT", -9999)
var.put.nc(fileoutput, "soil3c_13_vr",soil3c_13_vr)

att.put.nc(fileoutput, "soil4c_13_vr","missing_value", "NC_FLOAT", -9999)
var.put.nc(fileoutput, "soil4c_13_vr",soil4c_13_vr)

att.put.nc(fileoutput, "bacteriac_13_vr","missing_value", "NC_FLOAT", -9999)
var.put.nc(fileoutput, "bacteriac_13_vr",bacteriac_13_vr)

att.put.nc(fileoutput, "fungic_13_vr","missing_value", "NC_FLOAT", -9999)
var.put.nc(fileoutput, "fungic_13_vr",fungic_13_vr)

att.put.nc(fileoutput, "domc_13_vr","missing_value", "NC_FLOAT", -9999)
var.put.nc(fileoutput, "domc_13_vr",domc_13_vr)

att.put.nc(fileoutput, "seedc_13","missing_value", "NC_FLOAT", -9999)
var.put.nc(fileoutput, "seedc_13",seedc_13)

att.put.nc(fileoutput, "col_ctrunc_13_vr","missing_value", "NC_FLOAT", -9999)
var.put.nc(fileoutput, "col_ctrunc_13_vr",col_ctrunc_13_vr)

att.put.nc(fileoutput, "totlitc_13","missing_value", "NC_FLOAT", -9999)
var.put.nc(fileoutput, "totlitc_13",totlitc_13)

att.put.nc(fileoutput, "totcolc_13","missing_value", "NC_FLOAT", -9999)
var.put.nc(fileoutput, "totcolc_13",totcolc_13)

att.put.nc(fileoutput, "prod10c_13","missing_value", "NC_FLOAT", -9999)
var.put.nc(fileoutput, "prod10c_13",prod10c_13)

att.put.nc(fileoutput, "prod100c_13","missing_value", "NC_FLOAT", -9999)
var.put.nc(fileoutput, "prod100c_13",prod100c_13)

# 14C
att.put.nc(fileoutput, "cwdc_14_vr","missing_value", "NC_FLOAT", -9999)
var.put.nc(fileoutput, "cwdc_14_vr",cwdc_14_vr)

att.put.nc(fileoutput, "litr1c_14_vr","missing_value", "NC_FLOAT", -9999)
var.put.nc(fileoutput, "litr1c_14_vr",litr1c_14_vr)

att.put.nc(fileoutput, "litr2c_14_vr","missing_value", "NC_FLOAT", -9999)
var.put.nc(fileoutput, "litr2c_14_vr",litr2c_14_vr)

att.put.nc(fileoutput, "litr3c_14_vr","missing_value", "NC_FLOAT", -9999)
var.put.nc(fileoutput, "litr3c_14_vr",litr3c_14_vr)

att.put.nc(fileoutput, "soil1c_14_vr","missing_value", "NC_FLOAT", -9999)
var.put.nc(fileoutput, "soil1c_14_vr",soil1c_14_vr)

att.put.nc(fileoutput, "soil2c_14_vr","missing_value", "NC_FLOAT", -9999)
var.put.nc(fileoutput, "soil2c_14_vr",soil2c_14_vr)

att.put.nc(fileoutput, "soil3c_14_vr","missing_value", "NC_FLOAT", -9999)
var.put.nc(fileoutput, "soil3c_14_vr",soil3c_14_vr)

att.put.nc(fileoutput, "soil4c_14_vr","missing_value", "NC_FLOAT", -9999)
var.put.nc(fileoutput, "soil4c_14_vr",soil4c_14_vr)

att.put.nc(fileoutput, "bacteriac_14_vr","missing_value", "NC_FLOAT", -9999)
var.put.nc(fileoutput, "bacteriac_14_vr",bacteriac_14_vr)

att.put.nc(fileoutput, "fungic_14_vr","missing_value", "NC_FLOAT", -9999)
var.put.nc(fileoutput, "fungic_14_vr",fungic_14_vr)

att.put.nc(fileoutput, "domc_14_vr","missing_value", "NC_FLOAT", -9999)
var.put.nc(fileoutput, "domc_14_vr",domc_14_vr)

att.put.nc(fileoutput, "seedc_14","missing_value", "NC_FLOAT", -9999)
var.put.nc(fileoutput, "seedc_14",seedc_14)

att.put.nc(fileoutput, "col_ctrunc_14_vr","missing_value", "NC_FLOAT", -9999)
var.put.nc(fileoutput, "col_ctrunc_14_vr",col_ctrunc_14_vr)

att.put.nc(fileoutput, "totlitc_14","missing_value", "NC_FLOAT", -9999)
var.put.nc(fileoutput, "totlitc_14",totlitc_14)

att.put.nc(fileoutput, "totcolc_14","missing_value", "NC_FLOAT", -9999)
var.put.nc(fileoutput, "totcolc_14",totcolc_14)

att.put.nc(fileoutput, "prod10c_14","missing_value", "NC_FLOAT", -9999)
var.put.nc(fileoutput, "prod10c_14",prod10c_14)

att.put.nc(fileoutput, "prod100c_14","missing_value", "NC_FLOAT", -9999)
var.put.nc(fileoutput, "prod100c_14",prod100c_14)

# new file
#var.def.nc(fileoutput,"rc13_canair","NC_FLOAT",c("pft"))
#att.put.nc(fileoutput, "rc13_canair","missing_value", "NC_FLOAT", -9999)
#var.put.nc(fileoutput, "rc13_canair",rc13_canair)

#var.def.nc(fileoutput,"rc13_psnsun","NC_FLOAT",c("pft"))
#att.put.nc(fileoutput, "rc13_psnsun","missing_value", "NC_FLOAT", -9999)
#var.put.nc(fileoutput, "rc13_psnsun",rc13_psnsun)

#var.def.nc(fileoutput,"rc13_psnsha","NC_FLOAT",c("pft"))
#att.put.nc(fileoutput, "rc13_psnsha","missing_value", "NC_FLOAT", -9999)
#var.put.nc(fileoutput, "rc13_psnsha",rc13_psnsha)

#var.def.nc(fileoutput,"leafc_13","NC_FLOAT",c("pft"))
#att.put.nc(fileoutput, "leafc_13","missing_value", "NC_FLOAT", -9999)
#var.put.nc(fileoutput, "leafc_13",leafc_13)

#var.def.nc(fileoutput,"leafc_storage_13","NC_FLOAT",c("pft"))
#att.put.nc(fileoutput, "leafc_storage_13","missing_value", "NC_FLOAT", -9999)
#var.put.nc(fileoutput, "leafc_storage_13",leafc_storage_13)

#var.def.nc(fileoutput,"leafc_xfer_13","NC_FLOAT",c("pft"))
#att.put.nc(fileoutput, "leafc_xfer_13","missing_value", "NC_FLOAT", -9999)
#var.put.nc(fileoutput, "leafc_xfer_13",leafc_xfer_13)

#var.def.nc(fileoutput,"frootc_13","NC_FLOAT",c("pft"))
#att.put.nc(fileoutput, "frootc_13","missing_value", "NC_FLOAT", -9999)
#var.put.nc(fileoutput, "frootc_13",frootc_13)

#var.def.nc(fileoutput,"frootc_storage_13","NC_FLOAT",c("pft"))
#att.put.nc(fileoutput, "frootc_storage_13","missing_value", "NC_FLOAT", -9999)
#var.put.nc(fileoutput, "frootc_storage_13",frootc_storage_13)

#var.def.nc(fileoutput,"frootc_xfer_13","NC_FLOAT",c("pft"))
#att.put.nc(fileoutput, "frootc_xfer_13","missing_value", "NC_FLOAT", -9999)
#var.put.nc(fileoutput, "frootc_xfer_13",frootc_xfer_13)

#var.def.nc(fileoutput,"livestemc_13","NC_FLOAT",c("pft"))
#att.put.nc(fileoutput, "livestemc_13","missing_value", "NC_FLOAT", -9999)
#var.put.nc(fileoutput, "livestemc_13",livestemc_13)

#var.def.nc(fileoutput,"livestemc_storage_13","NC_FLOAT",c("pft"))
#att.put.nc(fileoutput, "livestemc_storage_13","missing_value", "NC_FLOAT", -9999)
#var.put.nc(fileoutput, "livestemc_storage_13",livestemc_storage_13)

#var.def.nc(fileoutput,"livestemc_xfer_13","NC_FLOAT",c("pft"))
#att.put.nc(fileoutput, "livestemc_xfer_13","missing_value", "NC_FLOAT", -9999)
#var.put.nc(fileoutput, "livestemc_xfer_13",livestemc_xfer_13)

#var.def.nc(fileoutput,"deadstemc_13","NC_FLOAT",c("pft"))
#att.put.nc(fileoutput, "deadstemc_13","missing_value", "NC_FLOAT", -9999)
#var.put.nc(fileoutput, "deadstemc_13",deadstemc_13)

#var.def.nc(fileoutput,"deadstemc_storage_13","NC_FLOAT",c("pft"))
#att.put.nc(fileoutput, "deadstemc_storage_13","missing_value", "NC_FLOAT", -9999)
#var.put.nc(fileoutput, "deadstemc_storage_13",deadstemc_storage_13)

#var.def.nc(fileoutput,"deadstemc_xfer_13","NC_FLOAT",c("pft"))
#att.put.nc(fileoutput, "deadstemc_xfer_13","missing_value", "NC_FLOAT", -9999)
#var.put.nc(fileoutput, "deadstemc_xfer_13",deadstemc_xfer_13)

#var.def.nc(fileoutput,"livecrootc_13","NC_FLOAT",c("pft"))
#att.put.nc(fileoutput, "livecrootc_13","missing_value", "NC_FLOAT", -9999)
#var.put.nc(fileoutput, "livecrootc_13",livecrootc_13)

#var.def.nc(fileoutput,"deadstemc_13","NC_FLOAT",c("pft"))
#att.put.nc(fileoutput, "deadstemc_13","missing_value", "NC_FLOAT", -9999)
#var.put.nc(fileoutput, "deadstemc_13",deadstemc_13)

att.put.nc(fileoutput,"NC_GLOBAL","title","NC_CHAR","isotopic 13 carbon pools and 14 carbon pools")

close.nc(fileinput)
close.nc(fileoutput)


# This code creates the seroprevalence by
# variable level plot for
# Seroprevalence of SARS-CoV-2 antibodies in Saint
# Petersburg, Russia paper (https://doi.org/10.1038/s41598-021-92206-y)
library(data.table)
library(ggplot2)
library(ggthemes)
library(ggrepel)

# Declare working directory beforehand in an environment variable
# SPB_COVID_STUDY_PATH = "path_to_your_folder"
# with the aid of usethis::edit_r_environ()
# Restart R session for the changes to make effect
setwd(Sys.getenv('SPB_COVID_STUDY_PATH'))

# Load the per-group prevalence computed by estimate_prevalence_by_variable.r
load("estimates/wave1/prevalence_by_variable_level.rdata")

# Show univariate prevalence for Abbott test
abbott_per_variable_prevalence <- prevalence_by_variable_level[prevalence_type == "univariate" &  serotest == "IgG_testB" & sensitivity != 1]
abbott_per_variable_prevalence[, index := 1:.N]

per_variable_prevalence <- ggplot(abbott_per_variable_prevalence, aes(x = pointest, y = rev(index), label = variable_level)) +
											geom_point(size = 2) +
											geom_errorbar(aes(xmin = lowerbound, xmax = upperbound), width = 0.2) +
											#geom_text_repel(aes(label = paste0(variable, ":", variable_level)), min.segment.length = 10e6, nudge_x = -0) +
											geom_text(aes(label = paste0(variable, ":", variable_level)), vjust=1) +

											geom_text(aes(label = paste0(pointest, "%")), hjust = 0.5, vjust=-0.5) +
											scale_x_continuous(name = "Adjusted prevalence") +
											scale_y_discrete(name = NULL) +
											theme_minimal() +
											theme(panel.grid.minor = element_blank(), axis.text.y = element_text(size = 8), text = element_text(size = 15))

#ggsave("media/wave1/per_variable_prevalence.png", width = 10, height = 25)


# user options
nox<-1; noy<-1;
paper<-'N'   # if paper=="Y" output on file, else screen
cleanup()

first.year.in.mean<-2030    # years where output is independent of initial conditions and used as "equilibrium"
last.year.in.mean<-2040

n.iterations<-10

include.probability<-TRUE

if (first.year.in.mean!=last.year.in.mean) myTitle<-paste(first.year.in.mean,'-',last.year.in.mean,sep='') else myTitle<-paste(first.year.in.mean)
# Scenarios, defined further later on

if (F) {
    scenario<-"TAC_constraints"
    fTarget<-0.4    # the prefered target F

    min<-0.05
    max<-0.25
    step<-0.05
    xlab.title<-'TAC constraints +/-'
}

if (T) {
    scenario<-"WKMAMPEL-Ftarget"
    min<-0.1       # min F
    max<-1.0
    step<-0.1
    xlab.title<-"Target-F"
}

do.simulation<-T          # do the simulations and create data files for plots
do.plots<-TRUE            # do the plots

T1<- 50000      # SSB that gives F=0
T2<-100000      # SSB that gives F=Ftarget

percentiles<-c(0.025,0.05,0.10,0.25,0.50,0.75,0.95,0.975)

######### end user options #########
do.HCR.batch<-function() {

outdir<-file.path(data.path,scenario)

#  files for output
ssb.out<-'HCR_SSB.dat'
yield.out<-'HCR_yield.dat'
F.out<-'HCR_F.dat'
prob.out<-'HCR_prob.dat'

if (do.simulation) {

  setwd(data.path)
  bio.interact<-FALSE

  #  runs are made in a separate dirictory
  scenario.dir<-scenario

  dir.create(scenario.dir,showWarnings = FALSE)

  SMS.files.single<-c("natmor.in","canum.in","west.in","weca.in","propmat.in","fleet_catch.in",
                      "fleet_names.in","fleet_info.dat","just_one.in","sms.psv","species_names.in",
                      "SSB_R.in","Prediction_F.in","reference_points.in","predict_stock_N.in",
                      "proportion_M_and_F_before_spawning.in",
                      "Exploitation_pattern.in","covariance_N.in","HCR_options.dat",
                      "SMS.dat","SMS.exe")

  for (from.file in SMS.files.single) {
    to.file<-file.path(data.path,scenario.dir,from.file)
    file.copy(from.file, to.file, overwrite = TRUE)
  }

  # read data and options into FLR objects
  control<-read.FLSMS.control()
  HCR<-read.FLSMS.predict.control(control=control,file='HCR_options.dat')

  sp.name<-control@species.names

  setwd(outdir)

  write.FLSMS.control(control,file='SMS.dat')

  iterations<-seq(min,max,step)

  # headers in output files
  heading<-"option "
  cat(paste(heading),file=ssb.out)
  cat(paste("SSB",formatC(percentiles*1000,width=3,flag='0'),sep=''),file=ssb.out,append=T); cat('\n',file=ssb.out,append=T)
  cat(paste(heading),file=yield.out)
  cat(paste("y",formatC(percentiles*1000,width=3,flag='0'),sep=''),file=yield.out,append=T); cat('\n',file=yield.out,append=T)
  cat(paste(heading),file=F.out)
  cat(paste("F",formatC(percentiles*1000,width=3,flag='0'),sep=''),file=F.out,append=T); cat('\n',file=F.out,append=T)
  cat(paste(heading," p.T1 \n"),file=prob.out)

  iter<-0

  for (option in (iterations)) {
      iter<-iter+1

      print(paste("Iteration:",iter))

      #if (HCR.vari !="") {
      #  slot(HCR,HCR.vari)[1,1]<-option
      #}
       HCR@no.MCMC.iterations <-n.iterations
       HCR@last.prediction.year <- last.year.in.mean

       smallF<-0.001
      if (scenario=="WKMAMPEL-Ftarget") {
            HCR@HCR[1,1]<-10
            HCR@Trigger["T1",1]<-T1
            HCR@Trigger["T2",1]<-T2 # just a very high number
            HCR@Trigger.a.b["FT1a",1]<- smallF
            HCR@Trigger.a.b["FT1b",1]<- 0
            HCR@Trigger.a.b["FT12a",1]<- smallF           # intercept
            HCR@Trigger.a.b["FT12b",1]<- option/(T2-T1)                      # slope
            HCR@Trigger.a.b["FT2a",1]<-option
            HCR@Trigger.a.b["FT2b",1]<-0
      }

      if (scenario=="TAC_constraints") {
           HCR@implementation["std",1]<-option
           HCR@TAC.constraints['min',1]<-1-option
           HCR@TAC.constraints['max',1]<-1+option

            HCR@HCR[1,1]<-10
            HCR@Trigger["T1",1]<-T1
            HCR@Trigger["T2",1]<-T2 # just a very high number
            HCR@Trigger.a.b["FT1a",1]<- smallF
            HCR@Trigger.a.b["FT1b",1]<- 0
            HCR@Trigger.a.b["FT12a",1]<- smallF           # intercept
            HCR@Trigger.a.b["FT12b",1]<- targetF/(T2-T1)                      # slope
            HCR@Trigger.a.b["FT2a",1]<-targetF
            HCR@Trigger.a.b["FT2b",1]<-0

      }

      write.FLSMS.predict.control(HCR,SMS=control,file='HCR_options.dat')

      #run SMS
      shell(paste("sms.exe","-mceval",sep=" "), invisible = TRUE)

      a<-Read.MCMC.SSB.rec.data(dir=outdir)
      a<-subset(a,Year>=first.year.in.mean & Year<=last.year.in.mean ,drop=T)
      #print(a)
      b<-tapply(a$SSB,list(a$Species.n), function(x) quantile(x,probs = percentiles))
      cat(paste(option,' '),file=ssb.out,append=TRUE)
      cat(b[[1]],file=ssb.out,append=TRUE)
      cat('\n',file=ssb.out,append=TRUE)

      q<-tapply(a$SSB,list(a$Year,a$Repetion,a$Iteration),sum)
      q[q>T1]<-0
      q[q>0]<-1
      p.T1<-sum(q)/(dim(q)[1]*dim(q)[2]*dim(q)[3])
      cat(paste(option,p.T1,'\n'),file=prob.out,append=TRUE)

      a<-Read.MCMC.F.yield.data(dir=outdir)
      a<-subset(a,Year>=first.year.in.mean & Year<=last.year.in.mean ,drop=T)
      b<-tapply(a$Yield,list(a$Species.n), function(x) quantile(x,probs =percentiles))
      cat(paste(option,' '),file=yield.out,append=TRUE)
      cat(b[[1]],file=yield.out,append=TRUE)
      cat('\n',file=yield.out,append=TRUE)

      b<-tapply(a$mean.F,list(a$Species.n), function(x) quantile(x,probs = percentiles))
      cat(paste(option,' '),file=F.out,append=TRUE)
      cat(b[[1]],file=F.out,append=TRUE)
      cat('\n',file=F.out,append=TRUE)
  }
}   # end do.simulations

if (do.plots) {

  setwd(outdir)
   # read data and options into FLR objects
  control<-read.FLSMS.control()
  HCR<-read.FLSMS.predict.control(control=control,file='HCR_options.dat')

  sp.name<-control@species.names

  ssb<-read.table(ssb.out,header=TRUE)
  yield<-read.table(yield.out,header=TRUE)
  prob<-read.table(prob.out,header=TRUE)
  fi<-read.table(F.out,header=TRUE)

  a<-merge(ssb,yield)
  a<-merge(a,prob)
  a<-merge(a,fi)

  if (paper=="Y") dev<-"wmf" else dev<-"screen"
  newplot(dev,nox,noy,dir=outdir,filename=paste("HCR_",sp.name,sep=''),Portrait=F);

  par(mar=c(5,4,4,5)+.1)
  s<-a$SSB500/1000
  y<-a$y500/1000
  x<-a$option
  x.lab<-xlab.title

  plot(x,s,ylab='SSB & Yield (1000 t)',xlab=x.lab ,ylim=c(min(s,y,0),max(s,y)),lty=1,type='l',lwd=2,col=1,main=myTitle)
  if (include.probability) {
    legend("topright",
       c('SSB','Yield','F', paste('p(SSB<',round(T1),'t)')),
       pch="   1",lty=c(1,2,5,3),col=c(1,2,3,4), lwd=rep(2,4))
  } else {
    legend(min(x),0.85*max(s,y),
       c('SSB','Yield','F'),
       pch="   ",lty=c(1,2,5),lwd=rep(2,3),col=c(1,2,3))
  }
  lines(x,y,lty=2,lwd=2,col=2)

  par(new=T)
  plot(x,a$F500,axes=F,xlab=x.lab, ylab=' ',lty=5,lwd=2,ylim=c(0,1),type='l',col=3)
  if (include.probability) {
    lines(x,a$p.T1,lty=3,type='b',pch="1",col=4)
    abline(h=0.05)
  }
  axis(side=4)

  mtext(side=4,line=3.0,"Probability & F")
  par(xaxs="r")

  if (paper=='Y') cleanup()

} #end do.plots

setwd(data.path)
}
do.HCR.batch()


library(fit)
library(tidyverse)
library(ggmap)
library(httr)
#library(ggpubr)
library(jsonlite)

#input: int from FIT, out: string
get_sport <- function(f){
	case_when(
			  f == 2 ~ "Biking",
			  f == 17 ~ "Hiking",
			  f == 1 ~ "Running",
			  f == 5 ~ "Swimming",
			  TRUE ~ "UNKNOWN_SPORT"
	)
}

#convert timestamp to date (weird, but off by only some minutes)
to_date <- function (t) {as.POSIXct(as.numeric(as.character(t)), origin="1990-01-01", tz="GMT+23")}

#array: hours k[1], mins k[2], secs k[3] (from int (seconds))
to_duration <- function (t,x="h") {
	if(x!="s"){
		t <- round(t/1000) #normalize if t comes from f.ex total_elapsed_time
	}
	hours <- t%/%3600
	mins <- t%%3600%/%60
	secs <- t%%60
	paste(hours,":",floor(mins),":",floor(secs),sep="")
}

#km/h -> min/km
to_pace <- function (t){
	#h <- 60/t
	#mins <- floor(h)
	#secs <- round((h-mins)*60)
	#ifelse(secs >= 60, paste(mins+1,":",secs-60,sep=""),paste(mins,":",secs,sep=""))
	h <- 3600/t
    #hours <- h%/%3600
    mins <- h%%3600%/%60
    secs <- h%%60
    #paste0(hours,":",floor(mins),":",floor(secs))
    paste0(floor(mins),":",floor(secs))
}

#m/s -> km/h
to_kmh <- function (ms) {ms*3.6}

#m/s -> min/100m
to_swimpace <- function (ms) {
	t <- 10**4/(ms*6) #[sec]
	mins <- floor(t)
	secs <- round((t-mins)*60)
	ifelse(secs >= 60, paste(mins+1,":",secs-60,sep=""),paste(mins,":",secs,sep=""))
}

#cadence, time (unit from dfs), poollength [m]
to_swolf <- function (cad,time,length){
	round(cad + (10**5/834)/(10**4/length),1)
}

convert_session <- function(buf,sport){
	if(sport=="Running" | sport=="Hiking"){
		data.frame("avg_hr"            = buf$avg_heart_rate,
				   "max_hr"            = buf$max_heart_rate,
				   "avg_speed"         = round(to_kmh(buf$avg_speed/1000),1),
				   "max_speed"         = round(to_kmh(buf$max_speed/1000),1),
				   "avg_pace"          = to_pace(round(to_kmh(buf$avg_speed/1000),1)),
				   "max_pace"          = to_pace(round(to_kmh(buf$max_speed/1000),1)),
				   "total_ascent"      = buf$total_ascent, # TODO
				   "total_descent"     = buf$total_descent, # TODO
				   "total_distance"    = round(buf$total_distance/10**5,2),
				   "total_time"        = to_duration(buf$total_elapsed_time),
				   "total_time_moving" = to_duration(buf$total_timer_time),
				   "num_laps"          = buf$num_laps,
				   "training_effect"   = buf$total_training_effect/10)
	}
	else if(sport=="Biking"){
		data.frame("avg_hr"            = buf$avg_heart_rate,
				   "max_hr"            = buf$max_heart_rate,
				   "avg_speed"         = round(to_kmh(buf$avg_speed/1000),1),
				   "max_speed"         = round(to_kmh(buf$max_speed/1000),1),
				   "total_ascent"      = buf$total_ascent, # TODO
				   "total_descent"     = buf$total_descent, # TODO
				   "total_distance"    = round(buf$total_distance/10**5,2),
				   "total_time"        = to_duration(buf$total_elapsed_time),
				   "total_time_moving" = to_duration(buf$total_timer_time),
				   "training_effect"   = buf$total_training_effect/10)
	}
	else if(sport=="Swimming"){
		data.frame("avg_cadence"       = buf$avg_cadence, #[Züge/min]
				   "total_cycles"      = buf$total_cycles, #Gesamtzahl Züge
				   "avg_speed"         = to_swimpace(buf$avg_speed),
				   "max_speed"         = to_swimpace(buf$max_speed),
				   "avg_swolf"         = to_swolf(buf$avg_cadence,buf$avg_speed,buf$pool_length),
				   "num_laps"          = buf$num_laps,
				   "pool_length"       = buf$pool_length/100,
				   "total_distance"    = round(buf$total_distance/10**5,2),#[km]
				   "total_time"        = to_duration(buf$total_elapsed_time), #[h:m:s]
				   "total_time_moving" = to_duration(buf$total_timer_time)) #[h:m:s]

	}
}

convert_lap <- function(buf,sport,pool_length=0){
	if(sport=="Running" | sport=="Hiking"){
		data.frame("avg_hr"            = buf$avg_heart_rate,
				   "avg_speed"         = round(to_kmh(buf$avg_speed/1000),1),
				   "max_speed"         = round(to_kmh(buf$max_speed/1000),1),
				   "avg_pace"          = to_pace(round(to_kmh(buf$avg_speed/1000),1)),
				   "total_distance"    = round(buf$total_distance/10**5,2),
				   "total_time"        = to_duration(buf$total_elapsed_time),
				   "total_time_moving" = to_duration(buf$total_timer_time))
	}
	else if(sport=="Biking"){
		data.frame("avg_hr"            = buf$avg_heart_rate,
				   "avg_speed"         = round(to_kmh(buf$avg_speed/1000),1),
				   "max_speed"         = round(to_kmh(buf$max_speed/1000),1),
				   "total_distance"    = round(buf$total_distance/10**5,2),
				   "total_time"        = to_duration(buf$total_elapsed_time),
				   "total_time_moving" = to_duration(buf$total_timer_time))
	}
	else if(sport=="Swimming"){
		data.frame("avg_cadence"       = buf$avg_cadence, #[Züge/min]
				   "total_cycles"      = buf$total_cycles, #Gesamtzahl Züge
				   "avg_speed"         = to_swimpace(buf$avg_speed),
				   "max_speed"         = to_swimpace(buf$max_speed),
				   "num_lengths"       = buf$num_active_lengths,
				   "avg_swolf"         = to_swolf(buf$avg_cadence,buf$avg_speed,pool_length),
				   "total_distance"    = round(buf$total_distance/10**5,2),#[km]
				   "total_time"        = to_duration(buf$total_elapsed_time), #[h:m:s]
				   "total_time_moving" = to_duration(buf$total_timer_time)) #[h:m:s]
	}
}

convert_record <- function(buf,sport){
	if(sport=="Running" | sport=="Hiking"){
		data.frame("distance" = round(buf$distance/10**5,3),
				   "hr"       = buf$heart_rate,
				   "speed"    = round(to_kmh(buf$speed/1000),1),
				   "pace"     = to_pace(round(to_kmh(buf$speed/1000),1)),
				   "pos_lat"  = buf$position_lat,
				   "pos_long" = buf$position_long,
				   "time"     = to_duration(buf$timestamp-file$session$start_time,"s"))
	}
	else if(sport=="Biking"){
		data.frame("distance" = round(buf$distance/10**5,3),
				   "hr"       = buf$heart_rate,
				   "speed"    = round(to_kmh(buf$speed/1000),1),
				   "pos_lat"  = buf$position_lat,
				   "pos_long" = buf$position_long,
				   "time"     = to_duration(buf$timestamp-file$session$start_time,"s"))
	}
}

convert_length <- function(buf,sport){
	if(sport=="Swimming"){
		data.frame("cadence"  = buf$avg_swimming_cadence, #[Züge/min]
				   "speed"    = to_swimpace(buf$avg_speed),
				   "swolf"    = to_swolf(buf$avg_swimming_cadence,buf$avg_speed,file$session$pool_length),
				   #"distance" = round(buf$distance/10**5,3),#[km]
				   "strokes"  = buf$total_strokes,
				   "time"     = to_duration(buf$start_time-file$session$start_time,"s")) #[h:m:s]
	}
}

#remove rows which contain any NA values
clean_frame <- function(buf,sport){
	buf[complete.cases(buf),]
}

#convert dataframe containing pos_lat and pos_long cols into array of altitudes
req <- function(p){
		points_comb <- paste(p$pos_lat,p$pos_long,sep=',')
		coords_lst <- paste(points_comb,collapse='|')

		elev_req <- GET(#"https://api.airmap.com/elevation/v1/ele",
						"https://api.opentopodata.org/v1/eudem25m?",  #dataset covers EU at 25m resolution
					    query = list(locations = coords_lst))
		print(paste("Requesting elevation for",nrow(p),"rows from API:",http_status(elev_req)$category))
		elev_req
}

act_files <- list.files('data/f/')
#contains all fit files to be processed
fit_files <- c()
for (f in act_files){
	sp <- unlist(strsplit(f,"[.]"))
	#print(sp[1:length(sp)-1])
	if(sp[length(sp)] == "FIT" | sp[length(sp)] == "fit"){
		#file is a fit file! save its name
		fit_files <- c(fit_files,sp[1:length(sp)-1])
	}
}

taglist <- data.frame()

for (f in fit_files){
	file <- read.fit(paste('data/f/',f,'.FIT',sep=""))

	file_sport_type <- get_sport(file$sport$sport)
	file_date <- to_date(file$session$start_time)
	file_session <- convert_session(file$session,file_sport_type)
	file_lap     <- convert_lap(file$lap,file_sport_type,ifelse(!is.null(file$session$pool_length),
																file$session$pool_length,0))
	#non-swimming: read record
	if(is.null(file$session$pool_length)){
		file_record  <- convert_record(file$record,file_sport_type)
	}
	#swimming: record for some reason useless, use length table
	else{
		file_record <- convert_length(file$length,file_sport_type)
	}

	out <- c()
	out$session <- clean_frame(file_session)
	out$lap <- clean_frame(file_lap)
	out$record <- clean_frame(file_record)
	out$tags <- c('Test_tag')

	if(!out$tags %in% taglist){
		taglist <- c(taglist,out$tags)
	}

	filename <- paste0("data/ACT_RDS/",gsub(":","-",gsub(" ","_",file_date)),"_",file_sport_type)
	print(paste("Processing",filename,"..."))
	print("")

	if(file_sport_type != "Swimming"){
		#add altitude values to record frame
		points <- out$record
		response <- c()
		points_split <- split(points, (as.numeric(rownames(points))-1) %/% 100)
		for (i in points_split){
			r <- req(i)
			warn_for_status(r)
			response <- c(response,fromJSON(content(r,as="text",encoding="UTF-8"))$results$elevation)
		}

		out$record$altitude <- unlist(response)

		#create own total_ascent + total_descent values
		alt <- unlist(response)
		asc <- 0
		dsc <- 0
		for (i in 1:(length(alt)-1)){
			if(alt[i] < alt[i+1])
				asc <- asc + alt[i+1]-alt[i]
			else
				dsc <- dsc + alt[i]-alt[i+1]
		}
		out$session$total_ascent2 <- asc
		out$session$total_descent2 <- dsc

		#create maps from lon/lat values
		map <- get_stamenmap(bbox = c(left=min(points$pos_long)-0.005,
									  bottom=min(points$pos_lat)-0.002,
									  right=max(points$pos_long)+0.005,
									  top=max(points$pos_lat)+0.002), zoom = 14)
		dput(map,paste0(filename,"_map.RData"))
		saveRDS(out,paste0(filename,".rds"))
	}
	break
}
saveRDS(taglist,"data/ACT_RDS/taglist.rds")


# print model_summary method ----
print.model_summary <- function(x, ...) {

  # prepate data ----
  x$sig <- ""
  x$sig[x$p_value <= 0.1] <- "."
  x$sig[x$p_value <= 0.05] <- "*"
  x$sig[x$p_value <= 0.01] <- "**"
  x$sig[x$p_value <= 0.001] <- "***"

  if (requireNamespace("knitr", quietly = TRUE)) {
    knitr::kable(x, digits = 3)
  } else {
    x$Estimate <- round(x$Estimate, digits = 3)
    x$Std_Error <- round(x$Std_Error, digits = 3)
    x$t_value <- round(x$t_value, digits = 3)
    x$p_value <- round(x$p_value, digits = 3)
    print(x)
  }
}

# print model_randfe method ----
print.model_randfe <- function(x, ...) {
  if (requireNamespace("knitr", quietly = TRUE)) {
    knitr::kable(x, digits = 3)
  } else {
    x$Estimate <- round(x$Estimate, digits = 3)
    print(x)
  }
}


#10X Genomics scRNAseq analysis of B. malayi mf +/- 1 uM Ivermectin treatment
#Reading and filtering raw feature barcode matrix results from 10X Genomics Cellranger output. Filtration completed with scCB2 R package followed by SoupX to remove cell free mRNA contamination. Script completes with filtred, processed seurat objects ready for cluster analysis.

#Install packages
BiocManager::install("scCB2")
install.packages("Seurat")
BiocManager::install("DropletUtils")
BiocManager::install("scDblFinder")
install.packages("SoupX")

#Load libraries
library(tidyverse)
library(ggplot2)
library(cowplot)
library(DropletUtils)
library(scCB2)
library(dplyr)
library(expss)
library(multtest)
library(tidyquant)
library(SummarizedExperiment)
library(scDblFinder)
library(monocle)
library(methods)
library(Matrix)
library(scater)
library(patchwork)
library(Seurat)
library(SoupX)
library(ggplot2)
library(ZamanianLabThemes)

# see package vignettes
vignette("scCB2")
browseVignettes("scDblFinder")

# Set PSOCK cluster setup_strategt to "sequential". Defult is "parallel". Required to use CB2CellFinder.
parallel:::setDefaultClusterOptions(setup_strategy = "sequential")

# set directories for tBM and utBM data sets
data.dir.tBM <- ("~/Box/ZamanianLab/SeqLibraries/Mapping/singlecell/scRNAesq_Bma_multi/scmulti_tBM/outs/raw_feature_bc_matrix")
data.dir.utBM <- ("~/Box/ZamanianLab/SeqLibraries/Mapping/singlecell/scRNAesq_Bma_multi/scmulti_utBM/outs/raw_feature_bc_matrix")

# Read in raw bc matrix from 10X Genomics Cellranger output
# read in raw data as a dgCMatrix
raw_tBM <- Read10xRaw(data.dir.tBM)
raw_utBM <- Read10xRaw(data.dir.utBM)

### Begin filtration of the raw data to remove empty droplets using scCB2

# run CB2 to distinguish real cells from empty droplets. Default lower=100
CBout_tBM <- CB2FindCell(raw_tBM, FDR_threshold = 0.01, lower = 100, Ncores = 2)
str(assay(CBout_tBM))
str(metadata(CBout_tBM))

CBout_utBM <- CB2FindCell(raw_utBM, FDR_threshold = 0.01, lower = 100, Ncores = 2)
str(assay(CBout_utBM))
str(metadata(CBout_utBM))

# extract the real cell matrix
RealCell_tBM <- GetCellMat(CBout_tBM)
str(RealCell_tBM)

RealCell_utBM <- GetCellMat(CBout_utBM)
str(RealCell_utBM)

# Create a Seurat object from the scCB2 filtered cells. Remove genes detected in less than 3 cells
tBM <- Seurat::CreateSeuratObject(counts = RealCell_tBM,  min.cells = 3, project = "tBM")
view(tBM@meta.data)

utBM <- Seurat::CreateSeuratObject(counts = RealCell_utBM, min.cells = 3,  project = "utBM")
view(utBM@meta.data)

# Estimating cell free mRNA contamination using SoupX package. SoupX requires a raw and a filtered bc matrix to estimate the % contamination. Because the cellranger filtered bc matrix removes many cells, the raw bc matrix output is filtered using scCB2 and then a new filtered bc matrix is made from this output for input into soupx for each sample. Additionally, SoupX can better parse out contamination when cluster information is supplied. Each filtered treatment group will be taken all the way through UMAP to retrieve cluster information for SoupX input. Because each sample is taken from the same sc prep, the background should be relatively the same...

# Normalize the data (non-subsetted)
norm_tBM <- NormalizeData(tBM, normalization.method = "CLR")
norm_utBM <- NormalizeData(utBM, normalization.method = "CLR")

# Identify genes in cells that vary in expression (high in some and low in others)
hvfeatures_tBM <- FindVariableFeatures(norm_tBM, selection.method = "vst", nfeatures = 2000)
hvfeatures_utBM <- FindVariableFeatures(norm_utBM, selection.method = "vst", nfeatures = 2000)

# Scaling the data (linear transformation) prior to PCA analysis.
all.genes_tBM <- rownames(norm_tBM)
scaled_tBM <- ScaleData(norm_tBM, features = all.genes_tBM)

all.genes_utBM <- rownames(norm_utBM)
scaled_utBM <- ScaleData(norm_utBM, features = all.genes_utBM)

# Run PCA analysis (linear dimensional reduction) on the scaled data
PCA_tBM <- RunPCA(scaled_tBM, features = VariableFeatures(object = hvfeatures_tBM))
PCA_utBM <- RunPCA(scaled_utBM, features = VariableFeatures(object = hvfeatures_utBM))

# Look at the variance explained by each PC to identify if what PCs should be included in downstream annalysis
ElbowPlot(PCA_tBM, reduction = "pca", ndims = 50)
ElbowPlot(PCA_utBM, reduction = "pca", ndims = 50)

# clustering the cells
knn_tBM <- FindNeighbors(PCA_tBM, dims = 1:44)
clusters_tBM <- FindClusters(knn_tBM, resolution = 0.5)

knn_utBM <- FindNeighbors(PCA_utBM, dims = 1:44)
clusters_utBM <- FindClusters(knn_utBM, resolution = 1.0)

# UMAP
UMAP_tBM <- RunUMAP(clusters_tBM, dims = 1:44)
DimPlot(UMAP_tBM, reduction = "umap", label = TRUE, cols = "polychrome") + ggtitle("UMAP, res = 0.5")

UMAP_utBM <- RunUMAP(clusters_utBM, dims = 1:44)
DimPlot(UMAP_utBM, reduction = "umap", label = TRUE, cols = "polychrome") + ggtitle("UMAP, res = 1.0")

# Load the raw 10X output and the scCB2 filtered bc matrices. The estimateSoup function to estimate the expression profile of the cell free mRNA (soup) is computed automatically when using the SoupChannel function.
souped_tBM = SoupChannel(raw_tBM, RealCell_tBM, calcSoupProfile = FALSE)
souped_tBM = estimateSoup(souped_tBM, soupRange=c(0,25))
souped_tBM

souped_utBM = SoupChannel(raw_utBM, RealCell_utBM, calcSoupProfile = FALSE)
souped_utBM = estimateSoup(souped_utBM, soupRange=c(0,25))
souped_utBM

#SoupX can better understand contamination is dimension reduction data is supplied.

Embeddings(UMAP_tBM)[,1:2]
UMAP_DR_tBM <- as.data.frame(Embeddings(UMAP_tBM)[,1:2]) # extract the DR from the UMAP
head(UMAP_DR_tBM)

souped_tBM = setClusters(souped_tBM, Idents(UMAP_tBM)) #add cluster ID to the metadata
souped_tBM = setDR(souped_tBM, UMAP_DR_tBM, c("RD1", "RD2")) #add DR to the metadata

Embeddings(UMAP_utBM)[,1:2]
UMAP_DR_utBM <- as.data.frame(Embeddings(UMAP_utBM)[,1:2]) # extract the DR from the UMAP
head(UMAP_DR_utBM)

souped_utBM = setClusters(souped_utBM, Idents(UMAP_utBM)) #add cluster ID to the metadata
souped_utBM = setDR(souped_utBM, UMAP_DR_utBM, c("RD1", "RD2")) #add DR to the metadata

# Estimating the contamination fraction for removal (automated method) (CenGen manually estimated using cell-specific marers and estimated a global contamination fraction of 6.45%)
souped_tBM = autoEstCont(souped_tBM) #estimated ~10% contamination (rho 0.10)

souped_utBM = autoEstCont(souped_utBM) #estimated ~13% contamination (rho 0.13) but when cluster resolution was set to 0.5 like the tBM the soup was estimated to be 0.8...soo......

# We have now calculated the contamination fraction for each cell and can use this to remove the contamination from the original count matrix.
out_tBM = adjustCounts(souped_tBM)
out_utBM = adjustCounts(souped_utBM)

# Create Seurat objects from the SoupX output
pro_tBM = CreateSeuratObject(out_tBM, min.cells = 3, project = "tBM")
pro_utBM = CreateSeuratObject(out_utBM, min.cells = 3, project = "utBM")

### Begin QC analysis to remove additional low quality cells

# Add mitochondrial representation to the metadata of each data set and view distribution
pro_tBM[["percent.mt"]] <- PercentageFeatureSet(pro_tBM, features = c("WBGene00225418" , "WBGene00225415", "WBGene00220387"))
view(pro_tBM@meta.data)
pro_tBM_metadata <- pro_tBM@meta.data
(tBM_mtrna_dis_plot <- pro_tBM_metadata %>%
    ggplot(aes(color=orig.ident, x=percent.mt, fill= orig.ident)) +
    geom_density(alpha = 0.2) +
    theme_classic() +
    scale_x_continuous(breaks = seq(0,100,10)) +
    ylab("Cell density") +
    NULL)

pro_utBM[["percent.mt"]] <- PercentageFeatureSet(pro_utBM, features = c("WBGene00225418" , "WBGene00225415", "WBGene00220387"))
view(pro_utBM@meta.data)
pro_utBM_metadata <- pro_utBM@meta.data
(utBM_mtrna_dis_plot <- pro_utBM_metadata %>%
    ggplot(aes(color=orig.ident, x=percent.mt, fill= orig.ident)) +
    geom_density(alpha = 0.2) +
    theme_classic() +
    scale_x_continuous(breaks = seq(0,100,10)) +
    ylab("Cell density") +
    NULL)

# Remove cells that express <= 10% mitochondrial representation in downstream subset function

# Quick overview glance via VlnPlot
VlnPlot(pro_tBM, features = c("nFeature_RNA", "nCount_RNA", "percent.mt"), ncol=3)
VlnPlot(pro_utBM, features = c("nFeature_RNA", "nCount_RNA", "percent.mt"), ncol=3)

# look at UMIs per cell across the dataset
(tBM_UMI_plot <- pro_tBM_metadata %>%
    ggplot(aes(color=orig.ident, x=nCount_RNA, fill= orig.ident)) +
    geom_histogram(binwidth = 10) +
    theme_classic() +
    xlab("Number of UMIs") +
    NULL)

(utBM_UMI_plot <- pro_utBM_metadata %>%
    ggplot(aes(color=orig.ident, x=nCount_RNA, fill= orig.ident)) +
    geom_histogram(binwidth = 10) +
    theme_classic() +
    xlab("Number of UMIs") +
    NULL)

# Remove cells that express x> 10,000 UMIs in downstream subset function

# look at gene representation for each cell and identify cells that are largely represented by a single or few genes
pro_tBM$Percent.Largest.Gene <- apply(
  tBM@assays$RNA@counts,
  2,
  function(x)(100*max(x))/sum(x))

tBM_metadata <- pro_tBM@meta.data

(lgst_gene_plot <- tBM_metadata %>%
    ggplot(aes(color=orig.ident, x=Percent.Largest.Gene, fill= orig.ident)) +
    geom_bar(stat = "count") +
    theme_classic() +
    scale_x_continuous(breaks = seq(0,80,5)) +
    ylab("Cell Count") +
    NULL)

pro_utBM$Percent.Largest.Gene <- apply(
  utBM@assays$RNA@counts,
  2,
  function(x)(100*max(x))/sum(x))

utBM_metadata <- pro_utBM@meta.data

(lgst_gene_plot <- utBM_metadata %>%
    ggplot(aes(color=orig.ident, x=Percent.Largest.Gene, fill= orig.ident)) +
    geom_bar(stat = "count") +
    theme_classic() +
    scale_x_continuous(breaks = seq(0,80,5)) +
    ylab("Cell Count") +
    NULL)

# Remove cells where a single gene represents >= 15% of the total cell genotype

# Visualize the distribution of genes detected per cell via histogram
(tBM_features <- tBM_metadata %>%
    ggplot(aes(color=orig.ident, x=nFeature_RNA, fill= orig.ident)) +
    geom_bar(stat = "count", show.legend = TRUE) +
    theme_classic() +
    scale_x_continuous(limits = c(0,10000)) +
    ylab("Cell Count") +
    xlab("Total genes") +
    NULL)

(utBM_features <- utBM_metadata %>%
    ggplot(aes(color=orig.ident, x=nFeature_RNA, fill= orig.ident)) +
    geom_bar(stat = "count", show.legend = TRUE) +
    theme_classic() +
    scale_x_continuous(limits = c(0,10000)) +
    ylab("Cell Count") +
    xlab("Total genes") +
    NULL)

# Combination of reads, genes, and percent.mt for each  cell
ggplot(tBM_metadata, aes( x = nCount_RNA, y = nFeature_RNA, color = percent.mt))+
  geom_point(size = 0.5, position = position_jitter(w = 4, h = 0.5))+
  scale_color_gradient(low = "blue", high = "red")+
  theme_classic()+
  facet_grid(~orig.ident)+
  xlab("Count depth")+
  ylab("Number of genes")+
  NULL

ggplot(utBM_metadata, aes( x = nCount_RNA, y = nFeature_RNA, color = percent.mt))+
  geom_point(size = 0.5, position = position_jitter(w = 4, h = 0.5))+
  scale_color_gradient(low = "blue", high = "red")+
  theme_classic()+
  facet_grid(~orig.ident)+
  xlab("Count depth")+
  ylab("Number of genes")+
  NULL

# Subset each seurat objected on the following parameters:
tBM_subset <- subset(tBM,
                     nCount_RNA < 10000 &
                       nFeature_RNA < 2500 &
                       percent.mt < 10 &
                       Percent.Largest.Gene < 15)
view(tBM_subset@meta.data)

utBM_subset <- subset(utBM,
                      nCount_RNA < 10000 &
                        nFeature_RNA < 2500 &
                        percent.mt < 10 &
                        Percent.Largest.Gene < 15)
view(utBM_subset@meta.data)

# use the tBM_subset and utBM_subsest seurat objects for further normalization and selection of informative genes


library(openxlsx)
library(tidyverse)
library(edgeR)
library(limma)
library(splines)
library(parallel)
library(TCseq)
require(gridExtra)
library(grid)
library(Seurat)
library(openxlsx)
library(ggplot2)
library(ggfortify)
library(jcolors)
require(gridExtra)
library(grid)
library(matrixStats)
library(tidyverse)
library(tidytext)
library(RColorBrewer)
library(parallel)
library(ComplexHeatmap)
library(circlize)
library(doParallel)

source("../Code/util_funcs.R")
source("../Code/util_funcsV2.R")

## Normaliization

narrow.peaks.dir <-  "~/work/sharedData/macs2_stringent/"
nr.peaks <- list.files(path = narrow.peaks.dir, pattern = ".narrowPeak")
X <- strsplit(nr.peaks, "\\.")
Names <- gsub("_peaks", "", sapply(X, "[", 1))
cond <- rep("extra", 8)
passage <- gsub("_S[0-9]","", c(sapply(strsplit(Names, "-"), "[" , 5)[-c(7,8)], "RH","RH_gDNA"))
treatment <- paste(cond, passage, sep = ".")
Sample <- gsub(".*_", "", Names)

expmnt <- data.frame(Names, cond, passage, treatment, Sample)
expmnt
# ind <- sort(as.numeric(gsub("P", "", gsub("RH", "300", gsub("RH_gDNA", "400",expmnt$passage)))), index.return = T)$ix
# expmnt[order(expmnt$passage[ind]),]

count <- read.xlsx("../Input/BulkATACToxoPlasma/macs2_Union/peak_gene_assigned_raw_counts.xlsx")

# cpm normalization

CPM <- cbind(count[,1:2],cpm(count[,3:ncol(count)]))
CPM.avg <- CPM[,-2] %>% group_by(gene_id) %>% summarise_all("mean")
# filter low expressed genes
keep <- rowSums(CPM.avg > 2) >= 3

count.avg <- count[,-2] %>% group_by(gene_id) %>% summarise_all("mean")
count.avg <-cbind(gene_id = count.avg$gene_id, round(count.avg[,-1], digits = 0))
#count.avg <- count.avg %>% dplyr::select(-contains("gDNA"))

x <- count.avg[keep, 2:ncol(count.avg)]
rownames(x) <- count.avg$gene_id[keep]
treatment <- expmnt$treatment
treatment <- factor(treatment, levels = unique(treatment))

# Creating DGElist object

y <- DGEList(counts = x, group = treatment)
y <- calcNormFactors(y)
y$samples

# logarithmic scale

logCPM <- cpm(y, log=TRUE, prior.count=3, normalized.lib.sizes=TRUE)
plotMDS(logCPM, cex = 0.8)

logCPM.df <- logCPM %>% data.frame() %>% rownames_to_column(var = "GeneID")
logCPM.df <- logCPM.df %>% mutate(across(c(2:8),.fns = ~./extra.RH_gDNA))
logCPM.df <- logCPM.df %>% dplyr::select(!contains("gDNA"))
write.xlsx(logCPM.df, "../Input/BulkATACToxoPlasma/macs2_Union/Toxo_tab_ATAC_seq_logCPM.xlsx")

## Correlation and clustering
bulk.RNA <-read.xlsx('../Input/compScBdTgPb/LabAdaptationRNA/toxo_table_batch_corrected_logCPM_expression_edgeR_DEGs_ap2_targs_phenotype_correlations_smeV2.xlsx')
bulk.RNA.mean <- bulk.RNA  %>% dplyr::select(contains(c("GeneName",'.extra_mean')) )
bulk.RNA.mean <- bulk.RNA.mean %>% dplyr::select(!contains(c("P7")))

ind1 <- sort(as.numeric(gsub('.extra_mean', '',
                             gsub('\\P', '',
                                  gsub('GeneName', '1',
                                       gsub("RH",  "300",
                                            colnames(bulk.RNA.mean)))))),index.return = T)$ix
bulk.RNA.mean <- bulk.RNA.mean[,ind1]

bulk.RNA.lng <- bulk.RNA.mean %>% pivot_longer(-GeneName, names_to = "passage", values_to = "logexpr")
bulk.RNA.lng$passage <- as.numeric(gsub("\\P", "",
                                        gsub(".extra_mean","",
                                             gsub("RH", "300", bulk.RNA.lng$passage))))

bulk.RNA.lng <- bulk.RNA.lng %>% filter(passage != "300")  # filter out passage 300(RH)
#saveRDS(bulk.RNA.lng , "../Input/BulkATACToxoPlasma/RData/bulk_rna_seq_gene_expr_passage.RData")

bulk.ATAC <- read.xlsx("../Input/BulkATACToxoPlasma/macs2_Union/Toxo_tab_ATAC_seq_logCPM.xlsx")
bulk.ATAC <- bulk.ATAC %>% dplyr::select(!contains("P37"))

ind2 <-  sort(as.numeric(gsub("extra.", "",
                              gsub("\\P", "",
                                   gsub("RH", "300",
                                        gsub("GeneID", "1", colnames(bulk.ATAC)))))), index.return = T)$ix

bulk.ATAC  <- bulk.ATAC[,ind2]
bulk.ATAC.lng <- bulk.ATAC  %>%  pivot_longer(-GeneID, names_to = "passage", values_to = "logexpr")
bulk.ATAC.lng$passage <- as.numeric(gsub("extra.RH", "300", gsub("extra.P", "", bulk.ATAC.lng$passage)))

bulk.ATAC.lng <- bulk.ATAC.lng %>% filter(passage != "300")# filter out passage 300(RH)
#saveRDS(bulk.ATAC.lng , "../Input/BulkATACToxoPlasma/RData/bulk_atac_seq_gene_expr_passage.RData")

bulk.rna <- bulk.RNA.lng
colnames(bulk.rna)[1] <- "GeneID"
bulk.atac <- bulk.ATAC.lng

comm.genes <- intersect(unique(bulk.rna$GeneID), unique(bulk.atac$GeneID))

# RNA
# no z-score scaling
bulk.rna.spline.fits <- lapply(1:length(comm.genes), function(i){
  tmp <- bulk.rna %>% dplyr::filter(GeneID == comm.genes[i]) %>%
    transmute(GeneID = GeneID, x = passage, y = logexpr)
  bulk.rna.sp <- smooth.spline(tmp$x, tmp$y)
  bulk.rna.sp <- predict(bulk.rna.sp, seq(10, 200, by = 10))
  mu <- data.frame(x = bulk.rna.sp$x, y = bulk.rna.sp$y) ## For regression do not scale
  mu <- data.frame(GeneID = rep(tmp$GeneID[1], length(mu[,1])), x = mu[,1], y = mu[,2])
  return(mu)
})

bulk.rna.spline.fits <- bind_rows(bulk.rna.spline.fits)

# ATAC
# no z-score scaling
bulk.atac.spline.fits <- lapply(1:length(comm.genes), function(i){
  tmp <- bulk.atac %>% dplyr::filter(GeneID == comm.genes[i]) %>%
    transmute(GeneID = GeneID, x = passage, y = logexpr)
  bulk.atac.sp <- smooth.spline(tmp$x, tmp$y)
  bulk.atac.sp <- predict(bulk.atac.sp, seq(10, 200, by = 10))
  mu <- data.frame(x = bulk.atac.sp$x, y = bulk.atac.sp$y)
  mu <- data.frame(GeneID = rep(tmp$GeneID[1], length(mu[,1])), x = mu[,1], y = mu[,2])
  return(mu)
})

bulk.atac.spline.fits <- bind_rows(bulk.atac.spline.fits)

bulk.rna.atac.spline.fits <- bind_cols(bulk.rna.spline.fits, bulk.atac.spline.fits[,2:3])
colnames(bulk.rna.atac.spline.fits) <- c('GeneID', 'x1', 'y1', 'x2', 'y2')

bulk.rna.atac.corr <- bulk.rna.atac.spline.fits %>% group_by(GeneID) %>% summarise(m.ex = mean(y1), m.ax = mean(y2), co = cor(y1, y2))

par(mfrow = c(1,1))
for(i in 1:10){
  tmp <- bulk.rna.atac.spline.fits %>% dplyr::filter(GeneID == unique(bulk.rna.atac.spline.fits$GeneID)[i])
  y.lim = c(min(c(tmp$y1, tmp$y1)), max(c(tmp$y2, tmp$y2)))
  plot(tmp$x1, tmp$y1, type = 'l', col = 'red', main = unique(bulk.rna.atac.spline.fits$GeneID)[i], ylim = y.lim)
  points(tmp$x2, tmp$y2, type = 'l', col = 'blue')

  # plot(tmp$x1, tmp$y1, type = 'l', col = 'red', main = paste('EXPR:', unique(sc.rna.atac.spline.fits$GeneID)[i]))
  # plot(tmp$x2, tmp$y2, type = 'l', col = 'blue', main = paste('ATAC:', unique(sc.rna.atac.spline.fits$GeneID)[i]))
  # plot(tmp$x2, tmp$y1 - tmp$y2, type = 'l', col = 'green', main = paste('Delay:', unique(sc.rna.atac.spline.fits$GeneID)[i]))
  Sys.sleep(0.9)
}

## fit spline and scale for clustering
#
# scale.rna.spline.fits <- lapply(1:length(comm.genes), function(i){
#   tmp <- bulk.rna %>% dplyr::filter(GeneID == comm.genes[i]) %>%
#     transmute(GeneID = GeneID, x = passage, y = logexpr)
#   bulk.rna.sp <- smooth.spline(tmp$x, tmp$y)
#   bulk.rna.sp <- predict(bulk.rna.sp, seq(10, 200, by = 10))
#   mu <- data.frame(x = bulk.rna.sp$x, y = bulk.rna.sp$y) ## For regression do not scale
#   mu <- data.frame(GeneID = rep(tmp$GeneID[1], length(mu[,1])), x = mu[,1], y = mu[,2])
#   return(mu)
# })
#
# scale.rna.spline.fits <- bind_rows(scale.rna.spline.fits)
#
# bulk.rna.dtw.wide <- scale.rna.spline.fits %>%
#   pivot_wider(names_from = 'GeneID', values_from = 'y') %>%
#   as.data.frame()
#
#
# scale.atac.spline.fits <- lapply(1:length(comm.genes), function(i){
#   tmp <- bulk.atac %>% dplyr::filter(GeneID == comm.genes[i]) %>%
#     transmute(GeneID = GeneID, x = passage, y = logexpr)
#   bulk.atac.sp <- smooth.spline(tmp$x, tmp$y)
#   bulk.atac.sp <- predict(bulk.atac.sp, seq(10, 200, by = 10))
#   mu <- data.frame(x = bulk.atac.sp$x, y = bulk.atac.sp$y)
#   mu <- data.frame(GeneID = rep(tmp$GeneID[1], length(mu[,1])), x = mu[,1], y = mu[,2])
#   return(mu)
# })
#
# scale.atac.spline.fits <- bind_rows(scale.atac.spline.fits)
#
# bulk.atac.dtw.wide <- scale.atac.spline.fits %>%
#   pivot_wider(names_from = 'GeneID', values_from = 'y') %>%
#   as.data.frame()

## Generate the clusters
num.clust <- 8L
bulk.rna.hc_dtws <- dtwClustCurves(bulk.rna.dtw.wide[2:ncol(bulk.rna.dtw.wide)], nclust = num.clust)
saveRDS(bulk.rna.hc_dtws, "../Input/BulkATACToxoPlasma/RData/bulk_rna_dtwclusters_8.RData")
#bulk.rna.hc_dtws <- readRDS("~/work/sharedData/bulk.rna.hc_dtws_8cluster.RData")
p <- plot(bulk.rna.hc_dtws, type = 'sc')
plot(bulk.rna.hc_dtws, type = "series", clus = 3L)
plot(bulk.rna.hc_dtws, type = "centroids", clus = 2L)

ggsave("../Input/BulkATACToxoPlasma/fig/dtw_rna_8cluster.png",
       plot = p,
       height = 14, width = 12, dpi = 300 )

bulk.rna.hc_dtws.df <- data.frame(GeneID = unique(colnames(bulk.rna.dtw.wide)[-1]),
                                  order = as.numeric(bulk.rna.hc_dtws$order),
                                  cluster = cutree(bulk.rna.hc_dtws,k = num.clust))

bulk.rna.expr.hc_dtws <- left_join(bulk.rna.spline.fits, bulk.rna.hc_dtws.df, by = "GeneID")

## ggplot version of rna clusters
df.plot.rna  <- bulk.rna.expr.hc_dtws
cluster.dtw <- paste("cluster",unique(df.plot.rna$cluster), sep = " " )

p <- lapply(unique(df.plot.rna$cluster), function(i){
  tmp <- df.plot.rna %>% dplyr::filter(cluster == i)
  ggplot(tmp, aes(x = x, y = y, color = GeneID)) +
    geom_line(size = 0.5) +
    theme_bw() +
    #ggtitle("rna") +
    ggtitle(cluster.dtw[i])+
    theme(strip.background = element_rect(fill = "white", colour = "black"),
          strip.text = element_text(size = 13, face = "bold"),
          plot.title = element_text(size = 20, face = "bold.italic", hjust = 0.5),
          axis.title = element_text(size = 20, face = "bold"),
          legend.position = "none",
          axis.text = element_text(size = 16)) +
    ylab("expr") + xlab("time")

})

p1 <- do.call(grid.arrange, c(p, nrow=3))

# genes in each cluster (RNA data)

rna.clust.stat <- bulk.rna.hc_dtws.df %>% group_by(cluster) %>% summarise(total = n())

## use cluster info from rna data to identify corresponding genes in atac
bulk.rna.hc_dtws.df
bulk.atac.acc.hc_dtws <- left_join(bulk.atac.spline.fits, bulk.rna.hc_dtws.df , by = "GeneID")

atac.clust.stat <- bulk.atac.acc.hc_dtws %>% group_by(cluster) %>% distinct(GeneID) %>% summarise(total = n())

cluster.dtw <- paste("cluster",unique(bulk.atac.acc.hc_dtws$cluster), sep = " " )

df.plot.atac  <- bulk.atac.acc.hc_dtws

p <- lapply(unique(df.plot.atac$cluster), function(i){
  tmp <- df.plot.atac %>% dplyr::filter(cluster == i)
  ggplot(tmp, aes(x = x, y = y, color = GeneID)) +
    geom_line(size = 0.5) +
    theme_bw() +
    ggtitle(cluster.dtw[i]) +
    theme(strip.background = element_rect(fill = "white", colour = "black"),
          strip.text = element_text(size = 13, face = "bold"),
          plot.title = element_text(size = 20, face = "bold.italic", hjust = 0.5),
          axis.title = element_text(size = 20, face = "bold"),
          legend.position = "none",
          axis.text = element_text(size = 16)) +
    ylab("expr") + xlab("time")

})

p3 <- do.call(grid.arrange, c(p, nrow=3))

p <- ggsave(filename="../Input/BulkATACToxoPlasma/fig/atac_corresponding_genes_in_dtw_rna_clusters.png",
            plot=p3,
            width = 14, height = 12,
            units = "in",
            dpi = 300)

### Regression model: From David:
##################################
# Functon to fit regression model
# y(t) = a + b * x(t + c) + e(t)
# by ordinary least squares
# with x and y periodic functions
##################################

rna <- bulk.rna.dtw.wide[,-1]
rownames(rna) <- bulk.rna.dtw.wide[,1]
ys <- rna

atac <- bulk.atac.dtw.wide[,-1]
rownames(atac) <- bulk.atac.dtw.wide[,1]
xs <- atac

align.xy <- function(x, y)
{
  n <- length(x)
  xbar <- mean(x)
  ybar <- mean(y)

  ## Center x and y
  x <- x - xbar
  y <- y - ybar

  ## Squared norms
  sqnrmx <- sum(x^2)
  sqnrmy <- sum(y^2)
  if (sqnrmx == 0 || sqnrmy == 0)
    return(list(a = ybar, b = 0, c = 0, xshifted = x))

  ## Create shifted versions of x
  shift <- 1:n
  idx <- sapply(1:n, seq.int, length.out = n)
  xx <- c(x,x)
  xshift <- matrix(xx[idx], nrow = n)

  ## Estimate shift
  cp <- crossprod(y, xshift)
  idx <- which.max(cp)

  ## Estimate intercept and scale
  b <- as.numeric(cp[idx]) / sqnrmx
  a <- ybar - b * xbar

  ## Goodness of fit
  Rsquared <- b^2 * sqnrmx / sqnrmy

  list(a = a, b = b, c = idx - 1, xshifted = xshift[,idx] + xbar,
       Rsquared = Rsquared)
}

### Test the function
# x <- sin(seq(0, pi, len=101))
# y <- 5 + 2 * x
# test <- estimate.lin.transfo(x, y)
# print(test)

## xs and ys are accessibility, expression matricies (fitted splies, with same points)
n <- ncol(xs) # number of genes
T <- nrow(xs) # number of time points
# i <- sample.int(n,1)
#matplot(tgrid, cbind(xs[,i], ys[,i]), type = "l")
out <- lapply(1:n, function(i) align.xy(xs[,i], ys[,i]))
xshift <- sapply(out, "[[", "xshifted")
a <- sapply(out, "[[", "a")
b <- sapply(out, "[[", "b")
c <- sapply(out, "[[", "c")
# Reformulate shift in [-T/2,T/2] instead of [0,T]
c[c > (T/2)] <- c[c > (T/2)] - T
Rsquared <- sapply(out, "[[", "Rsquared")

hist(c*6/T, main = "Distribution of shifts (Period = 6)", xlab = "Time shift")
summary(Rsquared)
png(file="../Input/BulkATACToxoPlasma/fig/atac_rna_RSquared_dist.png",
    width=600, height=350)
hist(Rsquared)
dev.off()


library(dplyr)

##
ss_draw = function(roster, no_match, n = 1e4, yes_match) {
  draw = replicate(n, sample(roster, size = length(roster), replace = FALSE))

  # remove self-matches
  draw = draw[, colSums(draw == roster) == 0]

  matchup = apply(draw, 2, cbind.data.frame, roster, stringsAsFactors = FALSE)
  matchup = lapply(matchup, setNames, c("Giver", "Receiver"))

  if (!missing(no_match)) {
    # remove no_match matches
    no_match = rbind(no_match, setNames(rev(no_match), names(no_match)))
    names(no_match) = c("Giver", "Receiver")
    matchup = Filter(f = function(x) nrow(dplyr::intersect(x, no_match)) == 0, x = matchup)
  }

  if (!missing(yes_match)) {
  	# TODO ensure yes_match matches
  }

  return(head(matchup, 1))
}


 # max correlation
parm<-"estParm"         # select estParm (estimated) or allParm (estimated plus derived variables)

################################

fit<-read.fit()
 cor<-fit$cor
if (parm=="estParm") {
  npar<-fit$nopar
  cor<-cor[1:npar,1:npar]
} else npar<-fir$npar

var.name<-seq(1,npar)
dimnames(cor)[2]<-list(var.name)
dimnames(cor)[1]<-list(var.name)

cor[cor==1]<-NA
cor[lower.tri(cor)]<-NA

n<-dim(cor)[1]
size<-n*n

a<- arr2dfny(cor,name="cor")
#a<-subset(a,is.na(cor)==F & cor!=0)
a<-subset(a,is.na(cor)==F )

b<-read.table(file.path(data.path,"par_exp.out"),comment.char = "#",header=T)
namesb<-names(b)
names(b)<-paste(namesb,"1",sep='')

tmp<-merge(a,b,by.x="index.1",by.y="parNo1")
head(tmp)
names(b)<-paste(namesb,"2",sep='')
tmp<-merge(tmp,b,by.x="index.2",by.y="parNo2")

subset(tmp,par1=='qq_s2_ini')

head(tmp)
a<-droplevels(subset(tmp,par1=='qq_s2_ini' & par2=='qq_s2_ini'))
tapply(a$cor,list(paste(a$species1,a$fleet1,a$age1),paste(a$species2,a$fleet2,a$age2)),sum)

spnames<-function(sp) {
 if (sp >0) s<-sp.names[sp] else {if (sp<0) s<-'NA' else if (sp==0) s<-'Other'}
 s
}
spnames<-c("NA","Other",sp.names)

if (nsp==1) {
   ab<-data.frame(par1=tmp$par1,par2=tmp$par2,cor=tmp$cor,year1=tmp$year1,year2=tmp$year2,q1=tmp$quarter1,q2=tmp$quarter2,age1=tmp$age1,age2=tmp$age2)
} else {
   ab<-data.frame(par1=tmp$par1,par2=tmp$par2,cor=tmp$cor,species1=spnames[tmp$species1+2],species2=spnames[tmp$species2+2],
      year1=tmp$year1,year2=tmp$year2,q1=tmp$quarter1,q2=tmp$quarter2,age1=tmp$age1,age2=tmp$age2,
      pred1=spnames[tmp$predator1+2],prey1=spnames[tmp$prey1+2],pred2=spnames[tmp$predator2+2],prey2=spnames[tmp$prey2+2])
}

cors<-ab[order(abs(ab$cor),decreasing = T),]
print(head(cors,10))

head(subset(cors,par2=="init_season_overlap"))


# codebook is here: https://www.cdc.gov/brfss/annual_data/2017/pdf/codebook17_llcp-v2-508.pdf
# data is here (weirdly the filename has spaces in it, so I renamed it)
# https://www.cdc.gov/brfss/annual_data/2017/files/LLCP2017XPT.zip

library(foreign)
df = read.xport("LLCP2017.XPT")
hist(df$SLEPTIM1[df$SLEPTIM1<=24])