select(rcp,sp,YrBin,type,NoCapRC = riskC,NoCapRCmn = riskCmn,NoCapRCsd = riskCsd,hcr)
tbl2    <- tabledat%>%
arrange(rcp, .by_group = TRUE)%>%
group_by(rcp,sp,YrBin)%>%
filter(hcr=="2 MT cap")%>%
arrange(sp, .by_group = TRUE)%>% group_by(rcp,sp,YrBin)%>%
arrange(YrBin, .by_group = TRUE)%>% group_by(rcp,sp,YrBin)%>%
arrange(type, .by_group = TRUE)%>% group_by(rcp,sp,YrBin)%>%
select(rcp,sp,YrBin,type,CapRC = riskC,CapRCmn = riskCmn,CapRCsd = riskCsd,hcr)
tbl <- merge(tbl1,tbl2, by=c("rcp","sp","YrBin","type"))
tbl <- tbl%>%mutate(deltaRC   = CapRC   - NoCapRC ,
deltaRCmn = CapRCmn - NoCapRCmn,
type2     = substr(type,1,3))
tbl$delaRC   <- round(tbl$deltaRC,1)
tbl$NoCapRC  <- paste0(as.character(round(tbl$NoCapRC,1)),"(",as.character(round(tbl$NoCapRCsd,1)),")")
tbl$CapRC    <- paste0(as.character(round(tbl$CapRC,1)),"(",as.character(round(tbl$CapRCsd,1)),")")
tbl <- tbl%>%
group_by(sp,YrBin,rcp,type2,NoCapRC,CapRC,deltaRC)%>%
select(sp,YrBin,rcp,type2,NoCapRC,CapRC,deltaRC)
tbl_dat_long <- reshape2::melt(data.frame(tbl), id=c("sp", "YrBin","rcp","type2"))
first_k      <- function(x,char=T) if(char) as.character(x[1]) else x[1]
tbl_dat      <- reshape2::dcast(tbl_dat_long, rcp+sp + YrBin ~ type2+variable, first_k, margins="treatment")
out <-
kable(tbl_dat[,-(1:2)], caption = "Table 1") %>%
kable_styling(full_width = F,font=10) %>%
#collapse_rows(columns = 1:2, valign = "top")%>%
pack_rows("a) RCP 4.5", 1, 12) %>%
pack_rows("b) RCP 8.5", 13, 24) %>%
pack_rows("walleye pollock", 1, 4) %>%
pack_rows("Pacific cod", 5, 8) %>%
pack_rows("arrowtooth flounder", 9, 12)%>%
pack_rows("walleye pollock", 13, 16) %>%
pack_rows("Pacific cod", 17, 20) %>%
pack_rows("arrowtooth flounder", 21, 24)
return(out)
}
tbl <- tableS1()
tbl
save_kable(tbl,file=file.path(main,"Figures/tableS1.html"))
tbl <- merge(tbl1,tbl2, by=c("rcp","sp","YrBin","type"))
tbl <- tbl%>%mutate(deltaRC   = CapRC   - NoCapRC ,
deltaRCmn = CapRCmn - NoCapRCmn,
type2     = substr(type,1,3))
round(tbl$deltaRC,1)
tableS1 <- function(){
tmp12       <- risk12
tmp13       <- risk13
tmp12$hcr   <- "No cap"
tmp13$hcr   <- "2 MT cap"
tabledat    <- rbind(tmp12,tmp13)
tbl1    <- tabledat%>%
arrange(rcp, .by_group = TRUE)%>%
group_by(rcp,sp,YrBin)%>%
filter(hcr=="No cap")%>%
arrange(sp, .by_group = TRUE)%>% group_by(rcp,sp,YrBin)%>%
arrange(YrBin, .by_group = TRUE)%>% group_by(rcp,sp,YrBin)%>%
arrange(type, .by_group = TRUE)%>% group_by(rcp,sp,YrBin)%>%
select(rcp,sp,YrBin,type,NoCapRC = riskC,NoCapRCmn = riskCmn,NoCapRCsd = riskCsd,hcr)
tbl2    <- tabledat%>%
arrange(rcp, .by_group = TRUE)%>%
group_by(rcp,sp,YrBin)%>%
filter(hcr=="2 MT cap")%>%
arrange(sp, .by_group = TRUE)%>% group_by(rcp,sp,YrBin)%>%
arrange(YrBin, .by_group = TRUE)%>% group_by(rcp,sp,YrBin)%>%
arrange(type, .by_group = TRUE)%>% group_by(rcp,sp,YrBin)%>%
select(rcp,sp,YrBin,type,CapRC = riskC,CapRCmn = riskCmn,CapRCsd = riskCsd,hcr)
tbl <- merge(tbl1,tbl2, by=c("rcp","sp","YrBin","type"))
tbl <- tbl%>%mutate(deltaRC   = CapRC   - NoCapRC ,
deltaRCmn = CapRCmn - NoCapRCmn,
type2     = substr(type,1,3))
tbl$delaRC   <- round(tbl$deltaRC,1)
tbl$NoCapRC  <- paste0(as.character(round(tbl$NoCapRC,1)),"(",as.character(round(tbl$NoCapRCsd,1)),")")
tbl$CapRC    <- paste0(as.character(round(tbl$CapRC,1)),"(",as.character(round(tbl$CapRCsd,1)),")")
tbl <- tbl%>%
group_by(sp,YrBin,rcp,type2,NoCapRC,CapRC,deltaRC)%>%
select(sp,YrBin,rcp,type2,NoCapRC,CapRC,deltaRC)
tbl_dat_long <- reshape2::melt(data.frame(tbl), id=c("sp", "YrBin","rcp","type2"))
first_k      <- function(x,char=T) if(char) as.character(x[1]) else x[1]
tbl_dat      <- reshape2::dcast(tbl_dat_long, rcp+sp + YrBin ~ type2+variable, first_k, margins="treatment")
out <-
kable(tbl_dat[,-(1:2)], caption = "Table 1") %>%
kable_styling(full_width = F,font=10) %>%
#collapse_rows(columns = 1:2, valign = "top")%>%
pack_rows("a) RCP 4.5", 1, 12) %>%
pack_rows("b) RCP 8.5", 13, 24) %>%
pack_rows("walleye pollock", 1, 4) %>%
pack_rows("Pacific cod", 5, 8) %>%
pack_rows("arrowtooth flounder", 9, 12)%>%
pack_rows("walleye pollock", 13, 16) %>%
pack_rows("Pacific cod", 17, 20) %>%
pack_rows("arrowtooth flounder", 21, 24)
return(out)
}
tbl <- tableS1()
tbl
save_kable(tbl,file=file.path(main,"Figures/tableS1.html"))
tableS1 <- function(){
tmp12       <- risk12
tmp13       <- risk13
tmp12$hcr   <- "No cap"
tmp13$hcr   <- "2 MT cap"
tabledat    <- rbind(tmp12,tmp13)
tbl1    <- tabledat%>%
arrange(rcp, .by_group = TRUE)%>%
group_by(rcp,sp,YrBin)%>%
filter(hcr=="No cap")%>%
arrange(sp, .by_group = TRUE)%>% group_by(rcp,sp,YrBin)%>%
arrange(YrBin, .by_group = TRUE)%>% group_by(rcp,sp,YrBin)%>%
arrange(type, .by_group = TRUE)%>% group_by(rcp,sp,YrBin)%>%
select(rcp,sp,YrBin,type,NoCapRC = riskC,NoCapRCmn = riskCmn,NoCapRCsd = riskCsd,hcr)
tbl2    <- tabledat%>%
arrange(rcp, .by_group = TRUE)%>%
group_by(rcp,sp,YrBin)%>%
filter(hcr=="2 MT cap")%>%
arrange(sp, .by_group = TRUE)%>% group_by(rcp,sp,YrBin)%>%
arrange(YrBin, .by_group = TRUE)%>% group_by(rcp,sp,YrBin)%>%
arrange(type, .by_group = TRUE)%>% group_by(rcp,sp,YrBin)%>%
select(rcp,sp,YrBin,type,CapRC = riskC,CapRCmn = riskCmn,CapRCsd = riskCsd,hcr)
tbl <- merge(tbl1,tbl2, by=c("rcp","sp","YrBin","type"))
tbl <- tbl%>%mutate(deltaRC   = CapRC   - NoCapRC ,
deltaRCmn = CapRCmn - NoCapRCmn,
type2     = substr(type,1,3))
tbl$delaRC   <- as.character(round(tbl$deltaRC,1))
tbl$NoCapRC  <- paste0(as.character(round(tbl$NoCapRC,1)),"(",as.character(round(tbl$NoCapRCsd,1)),")")
tbl$CapRC    <- paste0(as.character(round(tbl$CapRC,1)),"(",as.character(round(tbl$CapRCsd,1)),")")
tbl <- tbl%>%
group_by(sp,YrBin,rcp,type2,NoCapRC,CapRC,deltaRC)%>%
select(sp,YrBin,rcp,type2,NoCapRC,CapRC,deltaRC)
tbl_dat_long <- reshape2::melt(data.frame(tbl), id=c("sp", "YrBin","rcp","type2"))
first_k      <- function(x,char=T) if(char) as.character(x[1]) else x[1]
tbl_dat      <- reshape2::dcast(tbl_dat_long, rcp+sp + YrBin ~ type2+variable, first_k, margins="treatment")
out <-
kable(tbl_dat[,-(1:2)], caption = "Table 1") %>%
kable_styling(full_width = F,font=10) %>%
#collapse_rows(columns = 1:2, valign = "top")%>%
pack_rows("a) RCP 4.5", 1, 12) %>%
pack_rows("b) RCP 8.5", 13, 24) %>%
pack_rows("walleye pollock", 1, 4) %>%
pack_rows("Pacific cod", 5, 8) %>%
pack_rows("arrowtooth flounder", 9, 12)%>%
pack_rows("walleye pollock", 13, 16) %>%
pack_rows("Pacific cod", 17, 20) %>%
pack_rows("arrowtooth flounder", 21, 24)
return(out)
}
# to print table set eval =T
tbl <- tableS1()
tbl
save_kable(tbl,file=file.path(main,"Figures/tableS1.html"))
tableS1 <- function(){
tmp12       <- risk12
tmp13       <- risk13
tmp12$hcr   <- "No cap"
tmp13$hcr   <- "2 MT cap"
tabledat    <- rbind(tmp12,tmp13)
tbl1    <- tabledat%>%
arrange(rcp, .by_group = TRUE)%>%
group_by(rcp,sp,YrBin)%>%
filter(hcr=="No cap")%>%
arrange(sp, .by_group = TRUE)%>% group_by(rcp,sp,YrBin)%>%
arrange(YrBin, .by_group = TRUE)%>% group_by(rcp,sp,YrBin)%>%
arrange(type, .by_group = TRUE)%>% group_by(rcp,sp,YrBin)%>%
select(rcp,sp,YrBin,type,NoCapRC = riskC,NoCapRCmn = riskCmn,NoCapRCsd = riskCsd,hcr)
tbl2    <- tabledat%>%
arrange(rcp, .by_group = TRUE)%>%
group_by(rcp,sp,YrBin)%>%
filter(hcr=="2 MT cap")%>%
arrange(sp, .by_group = TRUE)%>% group_by(rcp,sp,YrBin)%>%
arrange(YrBin, .by_group = TRUE)%>% group_by(rcp,sp,YrBin)%>%
arrange(type, .by_group = TRUE)%>% group_by(rcp,sp,YrBin)%>%
select(rcp,sp,YrBin,type,CapRC = riskC,CapRCmn = riskCmn,CapRCsd = riskCsd,hcr)
tbl <- merge(tbl1,tbl2, by=c("rcp","sp","YrBin","type"))
tbl <- tbl%>%mutate(deltaRC   = CapRC   - NoCapRC ,
deltaRCmn = CapRCmn - NoCapRCmn,
type2     = substr(type,1,3))
tbl$delaRC   <- (round(tbl$deltaRC,1))
tbl$NoCapRC  <- paste0(as.character(round(tbl$NoCapRC,1)),"(",as.character(round(tbl$NoCapRCsd,1)),")")
tbl$CapRC    <- paste0(as.character(round(tbl$CapRC,1)),"(",as.character(round(tbl$CapRCsd,1)),")")
tbl <- tbl%>%
group_by(sp,YrBin,rcp,type2,NoCapRC,CapRC,deltaRC)%>%
select(sp,YrBin,rcp,type2,NoCapRC,CapRC,deltaRC)
tbl_dat_long <- reshape2::melt(data.frame(tbl), id=c("sp", "YrBin","rcp","type2"))
first_k      <- function(x,char=T) if(char) as.character(x[1]) else x[1]
tbl_dat      <- reshape2::dcast(tbl_dat_long, rcp+sp + YrBin ~ type2+variable, first_k, margins="treatment")
out <-
kable(tbl_dat[,-(1:2)], caption = "Table 1") %>%
kable_styling(full_width = F,font=10) %>%
#collapse_rows(columns = 1:2, valign = "top")%>%
pack_rows("a) RCP 4.5", 1, 12) %>%
pack_rows("b) RCP 8.5", 13, 24) %>%
pack_rows("walleye pollock", 1, 4) %>%
pack_rows("Pacific cod", 5, 8) %>%
pack_rows("arrowtooth flounder", 9, 12)%>%
pack_rows("walleye pollock", 13, 16) %>%
pack_rows("Pacific cod", 17, 20) %>%
pack_rows("arrowtooth flounder", 21, 24)
return(out)
}
tbl <- tableS1()
tbl
save_kable(tbl,file=file.path(main,"Figures/tableS1.html"))
tableS1 <- function(){
tmp12       <- risk12
tmp13       <- risk13
tmp12$hcr   <- "No cap"
tmp13$hcr   <- "2 MT cap"
tabledat    <- rbind(tmp12,tmp13)
tbl1    <- tabledat%>%
arrange(rcp, .by_group = TRUE)%>%
group_by(rcp,sp,YrBin)%>%
filter(hcr=="No cap")%>%
arrange(sp, .by_group = TRUE)%>% group_by(rcp,sp,YrBin)%>%
arrange(YrBin, .by_group = TRUE)%>% group_by(rcp,sp,YrBin)%>%
arrange(type, .by_group = TRUE)%>% group_by(rcp,sp,YrBin)%>%
select(rcp,sp,YrBin,type,NoCapRC = riskC,NoCapRCmn = riskCmn,NoCapRCsd = riskCsd,hcr)
tbl2    <- tabledat%>%
arrange(rcp, .by_group = TRUE)%>%
group_by(rcp,sp,YrBin)%>%
filter(hcr=="2 MT cap")%>%
arrange(sp, .by_group = TRUE)%>% group_by(rcp,sp,YrBin)%>%
arrange(YrBin, .by_group = TRUE)%>% group_by(rcp,sp,YrBin)%>%
arrange(type, .by_group = TRUE)%>% group_by(rcp,sp,YrBin)%>%
select(rcp,sp,YrBin,type,CapRC = riskC,CapRCmn = riskCmn,CapRCsd = riskCsd,hcr)
tbl <- merge(tbl1,tbl2, by=c("rcp","sp","YrBin","type"))
tbl <- tbl%>%mutate(deltaRC   = CapRC   - NoCapRC ,
deltaRCmn = CapRCmn - NoCapRCmn,
type2     = substr(type,1,3))
tbl$delaRC   <- (round(tbl$deltaRC,1))
tbl$NoCapRC  <- paste0(as.character(round(tbl$NoCapRC,1))," (",as.character(round(tbl$NoCapRCsd,1)),")")
tbl$CapRC    <- paste0(as.character(round(tbl$CapRC,1))," (",as.character(round(tbl$CapRCsd,1)),")")
tbl <- tbl%>%
group_by(sp,YrBin,rcp,type2,NoCapRC,CapRC,deltaRC)%>%
select(sp,YrBin,rcp,type2,NoCapRC,CapRC,deltaRC)
tbl_dat_long <- reshape2::melt(data.frame(tbl), id=c("sp", "YrBin","rcp","type2"))
first_k      <- function(x,char=T) if(char) as.character(x[1]) else x[1]
tbl_dat      <- reshape2::dcast(tbl_dat_long, rcp+sp + YrBin ~ type2+variable, first_k, margins="treatment")
out <-
kable(tbl_dat[,-(1:2)], caption = "Table 1") %>%
kable_styling(full_width = F,font=10) %>%
#collapse_rows(columns = 1:2, valign = "top")%>%
pack_rows("a) RCP 4.5", 1, 12) %>%
pack_rows("b) RCP 8.5", 13, 24) %>%
pack_rows("walleye pollock", 1, 4) %>%
pack_rows("Pacific cod", 5, 8) %>%
pack_rows("arrowtooth flounder", 9, 12)%>%
pack_rows("walleye pollock", 13, 16) %>%
pack_rows("Pacific cod", 17, 20) %>%
pack_rows("arrowtooth flounder", 21, 24)
return(out)
}
tbl <- tableS1()
tbl
save_kable(tbl,file=file.path(main,"Figures/tableS1.html"))
head(risk12)  # preview the risk table for "No cap" simulations
head(risk13)  # preview the risk table for "2 MT cap" simulations
data.frame("No Cap" = c(
C_thresh_12_1$thrsh_x,
C_thresh_12_2$thrsh_x,
C_thresh_12_3$thrsh_x),
"2 MT Cap" = c(
C_thresh_13_1$thrsh_x,
C_thresh_13_2$thrsh_x,
C_thresh_13_3$thrsh_x))
c(
C_thresh_12_1$thrsh_x,
C_thresh_12_2$thrsh_x,
C_thresh_12_3$thrsh_x)
C_thresh_12_2$thrsh_x
C_thresh_12_2$thrsh_x # Temperature tipping point for p cod under "No cap" simulations
C_thresh_12_1$thrsh_x # Temperature tipping point for pollock under "No cap" simulations
C_thresh_12_3$thrsh_x # No tipping point was found for arrowtooth under "No cap" simulations
data.frame("No Cap" = c(
C_thresh_12_1$thrsh_x,
C_thresh_12_2$thrsh_x,
C_thresh_12_3$thrsh_x),
"2 MT Cap" = c(
C_thresh_13_1$thrsh_x,
C_thresh_13_2$thrsh_x,
C_thresh_13_3$thrsh_x))
mean(C_thresh_12_2$thrsh_x # Temperature tipping point for p cod under "No cap" simulations)
)
mean(C_thresh_12_2$thrsh_x # Temperature tipping point for p cod under "No cap" simulations))
tmp <- data.frame("No Cap" = c(
``
tmp <- data.frame("No Cap" = c(
C_thresh_12_1$thrsh_x,
C_thresh_12_2$thrsh_x,
C_thresh_12_3$thrsh_x),
"2 MT Cap" = c(
C_thresh_13_1$thrsh_x,
C_thresh_13_2$thrsh_x,
C_thresh_13_3$thrsh_x))
mean(tmp)
tmp
as.numeric(tmp)
unlist(tmp)
mean(unlist(tmp))
sd(unlist(tmp))
#'-------------------------------------
#'  threshold
#'-------------------------------------
#' Get threshold for gam relationship based on Large et al. 2014
#'
#' @param dat is a data.frame with t=date and dat=data to plot
#' @param x is the predictor variable of the gam fitted (newdata)
#' @param Catch is the y variable (data)
#' @param TempIn is the x variable (data)
#'
#' 3@param subyr is the subset years for the tmp_gam
#' @param simul_set is the subset of simulations to evaluate
#' @param method three options, method = 1 is default
#' #@param adj1 is the first adjustment parm
#' @param rndN is the sig digits for the first derivative
#' @param rndN2 is the sig digits for the second derivative
#' @param boot_n    # number of bootstrap runs
#' @param boot_nobs # optional subsample, if boot_nobs > sample nobs, is set = sample nobs
#' @param probIN probabilties for the quantile function
#' @param knotsIN number of knotsIN for the tmp_gam
#' @keywords Temperature, plot, data, ACLIM
#' @export
#' @examples
threshold<-function(
x         = seq(-3,10,.1),
hind      = NULL,
datIN     = datIN,
#subyr     = fut_yrs,
simul_set = c(6,9,11),
#adj1      = adj,
spanIN    = span_set,
rndN      = 6,
rndN2     = 6,
method    = 1,
smooth_yr = 1,
boot_n    = 1000,
boot_nobs = 24600,
probIN    = c(.025,.5,.975),
sdmult    = 1,
knotsIN   = 4){
require(rootSolve)
require(dplyr)
# get detla C
# From Large et al. "The shape of the relationship between a response and pressure is captured in the smoothing function s(X).
# Values of the pressure variable that influence the response in a particular direction can be enumerated by
# recognizing qualities of the shape of the smoothing function. The first derivative sˆ’(X)of s(X)indicates
# regions where a pressure variable causes a negative [sˆ’(X) , 0] or positive [sˆ’(X) . 0] response to an
# ecological indicator. Further, the second derivative sˆ”(X) denotes regions where ˆs’(X) changes sign and
# a threshold is crossed [0 , sˆ”(X) . 0]. To measure the uncertainty surrounding both sˆ’(X)and sˆ”(X),
# we estimated the first and second derivatives using finite differ- ences for each bootstrap replicated
# smoothing term sbr(X). Both ˆsi’(X)and sˆi”(X) were sorted into ascending order and the value of the
# 2.5% and 97.5% quantiles of sˆi’(X)and sˆi”(X)were considered the 95% CI for the first and second derivative
# of the smoothing function (Buckland, 1984). A significant trend sˆ’(X) or threshold sˆ”(X) was identified
# when the 95% CI crossed zero for either derivative (Fewster et al., 2000; Lindegren et al., 2012). "
# from Samhouri et al. 21
#and red dotted arrow indicates the best estimate of the location of the threshold (i.e., where the second
#  derivative is most difference from zero within the threshold range). See
# Fit gam
#------------------------------------
tmp_gam   <-  gam(delta_var_prcnt ~ s(TempC,k=knotsIN,bs="tp"),data = datIN)
hat       <-  predict(tmp_gam,se.fit=TRUE, newdata = data.frame(TempC=x) )
dd        <-  datIN%>%mutate(TempC = round(TempC,2) )%>%select(TempC, delta_var_prcnt)
dd$num    <-  1:length(dd[,1])
Deriv1    <- Deriv2<-hatFit<-hatse<-matrix(NA,boot_n,length(x))
gmlist<-list()
# now bootstrap for error:
#------------------------------------
#We measured uncertainty surrounding each tmp_gam by using a
#naive bootstrap with random sampling and replacement.
#For each indicator–pressure combination, bootstrap replicates
#(br ¼ i ... 1000) were selected from the raw data and each
#bri was fitted with a tmp_gam.
# For pressure–state relationships identified as
# nonlinear, we defined the location of the threshold as the inflection point, that is,
# the value of the pres- sure where the second derivative changed sign (Fewster et al. 2000,
# Bestelmeyer et al. 2011, Sam- houri et al. 2012, Large et al. 2013). For these
# analyses, we calculated the 95% CI of the smoothing function itself, along with
# its second derivative, via bootstrapping of the residuals in order to allow for autocorrelation.
for(int in 1:boot_n){
# get bootstraped sub-sample
nobs          <- length(dd$num)
if(boot_nobs > nobs)
boot_nobs   <- nobs
bootd         <- sample_n(dd,boot_nobs,replace = TRUE)
tmpgam        <- gam(delta_var_prcnt~s(TempC,k=knotsIN,bs="tp"),data = bootd)
tmpd          <- deriv2(tmpgam,simdat=x)
gmlist[[int]] <- tmpgam
Deriv1[int,]  <- tmpd$fd_d1
Deriv2[int,]  <- tmpd$fd_d2
hatFit[int,]  <- predict(tmpgam,se.fit=TRUE,newdata=data.frame(TempC=x))$fit
hatse[int,]   <- predict(tmpgam,se.fit=TRUE,newdata=data.frame(TempC=x))$se
}
# apply quantiles to bootstrap replicates
D1_se  <- apply(Deriv1,2,quantile,probs=probIN)
D2_se  <- apply(Deriv2,2,quantile,probs=probIN)
qnt    <- apply(hatFit,2,quantile,probs=probIN)
qntse  <- apply(hatse,2,quantile,probs=probIN)
# first to the gam using 1-3 methods
nobs<-length(x)
if(method==1)
hat_qnt<-data.frame(tmp=x,
up=hat$fit+qnt[3,]-qnt[2,],
mn=hat$fit,
dwn=hat$fit+qnt[1,]-qnt[2,])
if(method==2)
hat_qnt<-data.frame(tmp=x,
up=hat$fit+sdmult*qntse[2,],
mn=hat$fit,
dwn=hat$fit-sdmult*qntse[2,])
if(method==3)
hat_qnt<-data.frame(tmp=x,
up=hat$fit+sdmult*hat$se,
mn=hat$fit,
dwn=hat$fit-sdmult*hat$se)
hat_qnt$smoothed_mn  <- predict(loess(mn ~ tmp, data=hat_qnt, span=spanIN))
hat_qnt$smoothed_dwn <- predict(loess(dwn ~ tmp, data=hat_qnt, span=spanIN))
hat_qnt$smoothed_up  <- predict(loess(up ~ tmp, data=hat_qnt, span=spanIN))
# first derivative quantiles
df1_qnt<-data.frame(tmp = x,
up  = D1_se[3,],
mn  = D1_se[2,],
dwn = D1_se[1,])
# second derivative quantiles
df2_qnt<-data.frame(tmp = x,
up  = D2_se[3,],
mn  = D2_se[2,],
dwn = D2_se[1,])
# get difference in signs
getdelta<-function(xx,rnd = rndN2){
nn        <- length(xx)
xx        <- round(xx,rndN2)
delta     <- rep(NA,nn)
updn      <- c(0, diff(sign(xx)))
#updn[xx==0]<-0
ix        <- which(updn != 0)
#(xx[ix] + xx[ix-1])/2
sign(updn)[ix]
delta[ix] <- 1
return(list(delta=delta,ix=ix,updn=updn,xx=xx))
}
# determine peaks and valleys:
# 25% smoothing span
df1_qnt$smoothed_mn  <- predict(loess(mn  ~ tmp, data=df1_qnt, span=spanIN))
df1_qnt$smoothed_dwn <- predict(loess(dwn ~ tmp, data=df1_qnt, span=spanIN))
df1_qnt$smoothed_up  <- predict(loess(up  ~ tmp, data=df1_qnt, span=spanIN))
pks1    <- sort(c(findPeaks(df1_qnt$smoothed_mn),findPeaks(-df1_qnt$smoothed_mn)))
signif1 <- which(!between(0, df1_qnt$dwn, df1_qnt$up, incbounds=TRUE))
thrsh1  <- intersect(which(!between(0, df1_qnt$dwn, df1_qnt$up, incbounds=TRUE)),pks1)
df1_qnt$tmp[thrsh1]
# 25% smoothing span
df2_qnt$smoothed_mn  <- predict(loess(mn ~ tmp, data=df2_qnt, span=spanIN))
df2_qnt$smoothed_dwn <- predict(loess(dwn ~ tmp, data=df2_qnt, span=spanIN))
df2_qnt$smoothed_up  <- predict(loess(up ~ tmp, data=df2_qnt, span=spanIN))
pks2     <- sort(c(findPeaks(df2_qnt$smoothed_mn),findPeaks(-df2_qnt$smoothed_mn)))
pks2_up  <- sort(c(findPeaks(df2_qnt$smoothed_up),findPeaks(-df2_qnt$smoothed_up)))
pks2_dwn <- sort(c(findPeaks(df2_qnt$smoothed_dwn),findPeaks(-df2_qnt$smoothed_dwn)))
signif2  <- which(!between(0, df2_qnt$dwn, df2_qnt$up, incbounds=TRUE))
thrsh2_all   <- intersect(signif2,pks2)
thrsh2 <-  which(1==10)
if(length(thrsh2_all)>0)
thrsh2<-mean(thrsh2_all[which(abs(df2_qnt$smoothed_mn[thrsh2_all])==max(abs(df2_qnt$smoothed_mn[thrsh2_all])))],na.rm=T)
return( list(datIN     = datIN,
boot_nobs  = boot_nobs,
hat        = hat_qnt,
fdif1      = df1_qnt,
fdif2      = df2_qnt,
signif1    = signif1,
signif2    = signif2,
ix_pks     = pks2,
thrsh_max1 = thrsh2,
thrsh_all  = thrsh2_all,
thrsh_x    = df2_qnt$tmp[thrsh2],
thrsh_y    = df2_qnt$mn[thrsh2],
df1_qnt    = df1_qnt,
df2_qnt    = df2_qnt,
tmp_gam    = tmp_gam) )
}
source("R/rmd2md.R")
rmd2md(rmd_fl = "README_Holsman_EBMpaper",md_fl = "README")
source("R/rmd2md.R")
rmd2md(rmd_fl = "README_Holsman_EBMpaper",md_fl = "README")
source("R/rmd2md.R")
rmd2md(rmd_fl = "README_Holsman_EBMpaper",md_fl = "README")
source("R/rmd2md.R")
rmd2md(rmd_fl = "README_Holsman_EBMpaper",md_fl = "README")
source("R/rmd2md.R")
rmd2md(rmd_fl = "README_Holsman_EBMpaper",md_fl = "README")
# copy and paste this into R window (won't work within markdown)
source("R/rmd2md.R")
rmd2md(rmd_fl = "README_Holsman_EBMpaper",md_fl = "README")
source("R/rmd2md.R")
rmd2md(rmd_fl = "README_Holsman_EBMpaper",md_fl = "README")
source("R/sub_fun/rmd2md.R")
rmd2md(rmd_fl = "Overview",md_fl = "README")
getwd()
getwd()
knitr::opts_chunk$set(echo = TRUE)
source("R/make.R")
main<-getwd()
source("R/make.R")
head(sim_msm)
sim_msm
dat_2_5_12
dat2
head(dat_2_5_3)
rm(list=ls())
main
getwd()
main  <-  getwd()
setwd(main)
source("R/make.R")
dir(R)
dir("R")
dir("R/sub_scripts")
