## 2. More Data Cleaning ##

dc_listings <- dc_listings %>%
    select(-room_type, -city, -state,
           -latitude, -longitude, -zipcode,
           -host_response_rate, -host_acceptance_rate, -host_listings_count)
dc_columns <- colnames(dc_listings)

## 3. Handling Missing Values ##

dc_listings <- dc_listings %>%
  filter(
    !is.na(bedrooms),
    !is.na(bathrooms),
    !is.na(beds)
    )

## 6. Comparing Model Performance ##

set.seed(1)
library(caret)
train_indices <- createDataPartition(y = dc_listings[["tidy_price"]],
                                     p = 0.7,
                                     list = FALSE)
train_listings <- dc_listings[train_indices,]
test_listings <- dc_listings[-train_indices,]
train_control <- trainControl(method = "none")

two_feature_knn_model <- train(tidy_price ~ accommodates + bedrooms,
                               data = train_listings,
                               method = "knn",
                               trControl = train_control,
                               preProcess = c("center", "scale"))
three_feature_knn_model <- train(tidy_price ~ accommodates + bedrooms + maximum_nights,
                               data = train_listings,
                               method = "knn",
                               trControl = train_control,
                               preProcess = c("center", "scale"))
test_listings <- test_listings %>%
  mutate(
    two_feature_predictions = predict(two_feature_knn_model, newdata = test_listings),
    three_feature_predictions = predict(three_feature_knn_model, newdata = test_listings),
    two_feature_sq_error = (tidy_price - two_feature_predictions)^2,
    three_feature_sq_error = (tidy_price - three_feature_predictions)^2
  )

## 7. Long Format Data ##

two_feature_knn_model <- train(tidy_price ~ accommodates + bedrooms,
                               data = train_listings,
                               method = "knn",
                               trControl = train_control,
                               preProcess = c("center", "scale"))
three_feature_knn_model <- train(tidy_price ~ accommodates + bedrooms + maximum_nights,
                               data = train_listings,
                               method = "knn",
                               trControl = train_control,
                               preProcess = c("center", "scale"))

test_listings <- test_listings %>%
  mutate(
    two_feature_predictions = predict(two_feature_knn_model, newdata = test_listings),
    three_feature_predictions = predict(three_feature_knn_model, newdata = test_listings),
    two_feature_sq_error = (tidy_price - two_feature_predictions)^2,
    three_feature_sq_error = (tidy_price - three_feature_predictions)^2
  )
library(tidyr)
long_test_listings <- test_listings %>%
  pivot_longer(
    cols = two_feature_sq_error:three_feature_sq_error,
    names_to = "model",
    values_to = "sq_error"
  )

## 8. group_by() and summarize() ##

set.seed(1)
test_listings <- test_listings %>%
  pivot_longer(
    cols = two_feature_sq_error:three_feature_sq_error,
    names_to = "model",
    values_to = "sq_error"
  )
rmse_by_model <- test_listings %>%
  group_by(model) %>%
  summarize(
      rmse = sqrt(mean(sq_error))
  )
better_model <- "three_feature"

Data Analyst in R/Step 6 - Predictive Modeling and Machine Learning in R/2. Machine Learning Fundamentals in R/3. Multivariate K-Nearest Neighbors.r


remove(list=ls())
filedir<-"./"
source(paste0(filedir,"Rcode/allfunctions.r"))

load(filedir%&%"Rdatasets/RData_esl_slr_2100")

rsites.gpd.parameters<-read.delim(filedir%&%"CSV/Rasmussen/gpd_parameters_uhawaii19.tsv")  #need the information about the record length in years
#which for rasmussen varies

allparams.collect<-numeric(0)
allyears<-numeric(0)
for(ii in seq(nrow(rl1r))){
    allparam<-rl1r[ii,]
    id<-allparam$SLRID
    mm<-match(id,rsites.gpd.parameters$PSMSL_ID)
    if(!is.na(mm)&allparam$shape>(-0.5)){  #this is a condition for the Fisher Information matrix application to be valid
        allparam2<-rsites.gpd.parameters[mm,]
        years<-allparam2$GPD_Record_End-allparam2$GPD_Record_Start + 1   #this info to be used in the Fisher Info formula
        allyears<-rbind(allyears,c(id,years))
        allscalesshapes<-simulate.bivariate(10000,allparam$scale,allparam$shape,allparam$lambda,years)
        allTWLs<-RL.N(100,allscalesshapes[,2],allscalesshapes[,1],allparam$thresh,allparam$lambda)
        qqs<-quantile(allTWLs,prob=c(0.05,0.50,0.95))
        allparams.collect<-rbind(allparams.collect,
                         c(allparam[-c(2,3,4,5,16,17,18)],quantile(allscalesshapes[,1],prob=c(0.05,0.50,0.95)),var(allscalesshapes[,1]),quantile(allscalesshapes[,2],prob=c(0.05,0.50,0.95)),var(allscalesshapes[,2]),qqs))

}}

dimnames(allparams.collect)<-list(NULL,c(names(rl1r)[-c(2,3,4,5,16,17,18)],"Scale05","Scale50","Scale95","VScale","Shape05","Shape50","Shape95","VShape","TWL05s","TWLs","TWL95s"))
rasmussen.allparams.collect<-allparams.collect
rasmussen.allyears<-allyears

allparams.collect<-numeric(0)
allyears<-numeric(0)
for(ii in seq(nrow(rl1k))){
    allparam<-rl1k[ii,]
    id<-allparam$SLRID
    if(allparam$shape>(-0.5)){
        years<-35  #this is common to all sites for the model-based ESL estimates
        allyears<-rbind(allyears,c(id,years))
        allscalesshapes<-simulate.bivariate(10000,allparam$scale,allparam$shape,allparam$lambda,years)
        allTWLs<-RL.N(100,allscalesshapes[,2],allscalesshapes[,1],allparam$thresh,allparam$lambda)
        qqs<-quantile(allTWLs,prob=c(0.05,0.50,0.95))
        allparams.collect<-rbind(allparams.collect,
                                 c(allparam[c(1,6,7,8,9)],qqs,mean(allTWLs)))

    }}

dimnames(allparams.collect)<-list(NULL,c(names(rl1k)[c(1,6,7,8,9)],"TWL05s","TWL50s","TWL95s","TWLs"))
kirezci.allparams.collect<-allparams.collect
kirezci.allyears<-allyears

allparams.collect<-numeric(0)
allyears<-numeric(0)
for(ii in seq(nrow(rl1v))){
    allparam<-rl1v[ii,]
    id<-allparam$SLRID
    if(allparam$shape>(-0.5)){
        years<-170    #this is assigned for the estimate to work, even if it is not the length of years used (Vousdoukas et al. use a different approach to the estimation)
        allyears<-rbind(allyears,c(id,years))
        allscalesshapes<-simulate.bivariate(10000,allparam$scale,allparam$shape,allparam$lambda,years)
        allTWLs<-RL.N(100,allscalesshapes[,2],allscalesshapes[,1],allparam$thresh,allparam$lambda)
        qqs<-quantile(allTWLs,prob=c(0.05,0.50,0.95))
        allparams.collect<-rbind(allparams.collect,
                                 c(allparam[c(1,6,7,8,9,10)],qqs,mean(allTWLs),sqrt(var(allTWLs))))

    }}

dimnames(allparams.collect)<-list(NULL,c(names(rl1v)[c(1,6,7,8,9,10)],"TWL05s","TWL50s","TWL95s","TWLs","TWLses"))

vousdoukas.allparams.collect<-allparams.collect
vousdoukas.allyears<-allyears

#rasmussen

nsample<-1000
rasmussen.shape.scale.TWL.samples<-array(dim=c(nrow(rl1r),nsample,4))
for(ii in 1:nrow(rl1r)){
    id<-rl1r$SLRID[ii]
    mm<-match(id,rasmussen.allyears[,1])
    if(!is.na(mm)){
    shape<-rl1r$shape[ii]
    scale<-rl1r$scale[ii]
    lambda<-rl1r$lambda[ii]
    thresh<-rl1r$thresh[ii]
    allscalesshapes<-simulate.bivariate(nsample,scale,shape,lambda,rasmussen.allyears[mm,2])
    allTWL100s<-RL.N(100,allscalesshapes[,2],allscalesshapes[,1],thresh,lambda)
    allTWL1s<-RL.N(1.1,allscalesshapes[,2],allscalesshapes[,1],thresh,lambda)
    rasmussen.shape.scale.TWL.samples[ii,,]<-cbind(allscalesshapes,allTWL100s,allTWL1s)
}}

dimnames(rasmussen.shape.scale.TWL.samples)<-list(rl1r$SLRID,NULL,c("scale","shape","TWL100","TWL1s"))
rl1r.diff.100.1<-rasmussen.shape.scale.TWL.samples[,,3]-rasmussen.shape.scale.TWL.samples[,,4]

rasmussen.int.probproj<-rasmussen.freq.probproj<-array(dim=dim(proj1r)+c(0,1,0,0))
dimnames(rasmussen.int.probproj)<-dimnames(rasmussen.freq.probproj)<-list(c("mean","sd",dimnames(proj1r)[[1]][-c(1,2)]),
                                                            c("current",dimnames(proj1r)[[2]]),dimnames(proj1r)[[3]],
                                                            dimnames(proj1r)[[4]])

qs<-c(0.010,0.050,0.167,0.500,0.833,0.950,0.990,0.995,0.999)
samplesizes<-c(40,117,333,333,117,40,5,4)

set.seed(123)
for(ii in seq(nrow(rl1r))){
    print(ii)
    id<-rl1r$SLRID[ii]
    if(!all(is.na(rasmussen.shape.scale.TWL.samples[as.character(id),,]))){
    eslsample<-rasmussen.shape.scale.TWL.samples[as.character(id),,"TWL100"]
    shapesample<-rasmussen.shape.scale.TWL.samples[as.character(id),,"shape"]
    scalesample<-rasmussen.shape.scale.TWL.samples[as.character(id),,"scale"]
    allparam<-rl1r[ii,]
    thresh<-rep(allparam$thresh,1000)
    lambda<-rep(allparam$lambda,1000)

    rpscurrent<-RP(eslsample,shapesample,scalesample,thresh,lambda)
    eslsample<-eslsample*100

    for(slrmethod in c("rasmussen","bvw")){
        rasmussen.int.probproj[,"current",ii,slrmethod]<-c(mean(eslsample),sqrt(var(eslsample)),
                                                    quantile(eslsample,prob=qs-qs[1]))
        rasmussen.freq.probproj[,"current",ii,slrmethod]<-c(mean(rpscurrent),sqrt(var(rpscurrent)),
                                                     quantile(rpscurrent,prob=qs-qs[1]))

        for(scenario in rasmussenScenarios){

            slr.qs<-proj1r[-c(1,2),scenario,ii,slrmethod]
            if(!all(is.na(slr.qs))){
                slrsample<-numeric(0)
                for(ss in seq(length(samplesizes))){
                    a<-slr.qs[ss]
                    b<-slr.qs[ss+1]
                    uu<-runif(samplesizes[ss],a,b)
                    slrsample<-c(slrsample,uu)}
                ll<-length(slrsample)
                slrsample<-sample(slrsample, size=ll)  #randomized sample from the quantiles of the SLR projection
                eslsample<-eslsample[1:ll]
                sssample<-slrsample+eslsample
                rasmussen.int.probproj[,scenario,ii,slrmethod]<-c(mean(sssample),sqrt(var(sssample)),
                                                           quantile(sssample,prob=qs-qs[1]))
                sssample<--slrsample+eslsample
                rpssample<-RP(sssample/100,shapesample[1:ll],scalesample[1:ll],thresh[1:ll],lambda[1:ll])

                rasmussen.freq.probproj[,scenario,ii,slrmethod]<-c(mean(rpssample),sqrt(var(rpssample)),
                                                            quantile(rpssample,prob=qs-qs[1],na.rm=TRUE))
            }
        }
        }
}
}

#kirezci

nsample<-1000
kirezci.shape.scale.TWL.samples<-array(dim=c(nrow(rl1k),nsample,4))
for(ii in 1:nrow(rl1k)){
    id<-rl1k$SLRID[ii]
        shape<-rl1k$shape[ii]
        if(shape>-0.5){
        scale<-rl1k$scale[ii]
        lambda<-rl1k$lambda[ii]
        thresh<-rl1k$thresh[ii]
        allscalesshapes<-simulate.bivariate(nsample,scale,shape,lambda,35)
        allTWL100s<-RL.N(100,allscalesshapes[,2],allscalesshapes[,1],thresh,lambda)
        allTWL1s<-RL.N(1.1,allscalesshapes[,2],allscalesshapes[,1],thresh,lambda)
        kirezci.shape.scale.TWL.samples[ii,,]<-cbind(allscalesshapes,allTWL100s,allTWL1s)
    }}

dimnames(kirezci.shape.scale.TWL.samples)<-list(rl1k$SLRID,NULL,c("scale","shape","TWL100","TWL1"))
rl1k.diff.100.1<-kirezci.shape.scale.TWL.samples[,,3]-kirezci.shape.scale.TWL.samples[,,4]

kirezci.int.probproj<-kirezci.freq.probproj<-array(dim=dim(proj1k)+c(0,1,0,0))
dimnames(kirezci.int.probproj)<-dimnames(kirezci.freq.probproj)<-list(c("mean","sd",dimnames(proj1k)[[1]][-c(1,2)]),
                                                              c("current",dimnames(proj1k)[[2]]),dimnames(proj1k)[[3]],
                                                              dimnames(proj1k)[[4]])

qs<-c(0.010,0.050,0.167,0.500,0.833,0.950,0.990,0.995,0.999)
samplesizes<-c(40,117,333,333,117,40,5,4)

set.seed(123)
for(ii in seq(nrow(rl1k))){
    print(ii)
    id<-rl1k$SLRID[ii]
    if(!all(is.na(kirezci.shape.scale.TWL.samples[as.character(id),,]))){
        eslsample<-kirezci.shape.scale.TWL.samples[as.character(id),,"TWL100"]
        shapesample<-kirezci.shape.scale.TWL.samples[as.character(id),,"shape"]
        scalesample<-kirezci.shape.scale.TWL.samples[as.character(id),,"scale"]
        allparam<-rl1k[ii,]
        thresh<-rep(allparam$thresh,1000)
        lambda<-rep(allparam$lambda,1000)

        rpscurrent<-RP(eslsample,shapesample,scalesample,thresh,lambda)
        eslsample<-eslsample*100

        for(slrmethod in c("rasmussen","bvw")){
            kirezci.int.probproj[,"current",ii,slrmethod]<-c(mean(eslsample),sqrt(var(eslsample)),
                                                         quantile(eslsample,prob=qs-qs[1]))
            kirezci.freq.probproj[,"current",ii,slrmethod]<-c(mean(rpscurrent),sqrt(var(rpscurrent)),
                                                          quantile(rpscurrent,prob=qs-qs[1]))

            for(scenario in rasmussenScenarios){

                slr.qs<-proj1k[-c(1,2),scenario,ii,slrmethod]
                if(!all(is.na(slr.qs))){
                    slrsample<-numeric(0)
                    for(ss in seq(length(samplesizes))){
                        a<-slr.qs[ss]
                        b<-slr.qs[ss+1]
                        uu<-runif(samplesizes[ss],a,b)
                        slrsample<-c(slrsample,uu)}
                    ll<-length(slrsample)
                    slrsample<-sample(slrsample, size=ll)  #randomized sample from the quantiles of the SLR projection
                    eslsample<-eslsample[1:ll]
                    sssample<-slrsample+eslsample
                    kirezci.int.probproj[,scenario,ii,slrmethod]<-c(mean(sssample),sqrt(var(sssample)),
                                                                quantile(sssample,prob=qs-qs[1]))
                    sssample<--slrsample+eslsample
                    rpssample<-RP(sssample/100,shapesample[1:ll],scalesample[1:ll],thresh[1:ll],lambda[1:ll])

                    kirezci.freq.probproj[,scenario,ii,slrmethod]<-c(mean(rpssample),sqrt(var(rpssample)),
                                                                 quantile(rpssample,prob=qs-qs[1],na.rm=TRUE))
                }
            }
        }
    }
}

####vousdoukas

nsample<-1000
vousdoukas.shape.scale.TWL.samples<-array(dim=c(nrow(rl1v),nsample,4))
for(ii in 1:nrow(rl1v)){
    id<-rl1v$SLRID[ii]
        shape<-rl1v$shape[ii]
        if(shape>-0.5){
        scale<-rl1v$scale[ii]
        lambda<-rl1v$lambda[ii]
        thresh<-rl1v$thresh[ii]
        allscalesshapes<-simulate.bivariate(nsample,scale,shape,lambda,170)
        allTWL100s<-RL.N(100,allscalesshapes[,2],allscalesshapes[,1],thresh,lambda)
        allTWL1s<-RL.N(1.1,allscalesshapes[,2],allscalesshapes[,1],thresh,lambda)
        vousdoukas.shape.scale.TWL.samples[ii,,]<-cbind(allscalesshapes,allTWL100s,allTWL1s)
    }}

dimnames(vousdoukas.shape.scale.TWL.samples)<-list(rl1v$SLRID,NULL,c("scale","shape","TWL100","TWL1"))
rl1v.diff.100.1<-vousdoukas.shape.scale.TWL.samples[,,3]-vousdoukas.shape.scale.TWL.samples[,,4]

vousdoukas.int.probproj<-vousdoukas.freq.probproj<-array(dim=dim(proj1v)+c(0,1,0,0))
dimnames(vousdoukas.int.probproj)<-dimnames(vousdoukas.freq.probproj)<-list(c("mean","sd",dimnames(proj1v)[[1]][-c(1,2)]),
                                                              c("current",dimnames(proj1v)[[2]]),dimnames(proj1v)[[3]],
                                                              dimnames(proj1v)[[4]])

qs<-c(0.010,0.050,0.167,0.500,0.833,0.950,0.990,0.995,0.999)
samplesizes<-c(40,117,333,333,117,40,5,4)

set.seed(123)
for(ii in seq(nrow(rl1v))){
    print(ii)
    id<-rl1v$SLRID[ii]
    if(!all(is.na(vousdoukas.shape.scale.TWL.samples[as.character(id),,]))){
        eslsample<-vousdoukas.shape.scale.TWL.samples[as.character(id),,"TWL100"]
        shapesample<-vousdoukas.shape.scale.TWL.samples[as.character(id),,"shape"]
        scalesample<-vousdoukas.shape.scale.TWL.samples[as.character(id),,"scale"]
        allparam<-rl1v[ii,]
        thresh<-rep(allparam$thresh,1000)
        lambda<-rep(allparam$lambda,1000)

        rpscurrent<-RP(eslsample,shapesample,scalesample,thresh,lambda)
        eslsample<-eslsample*100

        for(slrmethod in c("rasmussen","bvw")){
            vousdoukas.int.probproj[,"current",ii,slrmethod]<-c(mean(eslsample),sqrt(var(eslsample)),
                                                         quantile(eslsample,prob=qs-qs[1]))
            vousdoukas.freq.probproj[,"current",ii,slrmethod]<-c(mean(rpscurrent),sqrt(var(rpscurrent)),
                                                          quantile(rpscurrent,prob=qs-qs[1]))

            for(scenario in rasmussenScenarios){

                slr.qs<-proj1v[-c(1,2),scenario,ii,slrmethod]
                if(!all(is.na(slr.qs))){
                    slrsample<-numeric(0)
                    for(ss in seq(length(samplesizes))){
                        a<-slr.qs[ss]
                        b<-slr.qs[ss+1]
                        uu<-runif(samplesizes[ss],a,b)
                        slrsample<-c(slrsample,uu)}
                    ll<-length(slrsample)
                    slrsample<-sample(slrsample, size=ll)  #randomized sample from the quantiles of the SLR projection
                    eslsample<-eslsample[1:ll]
                    sssample<-slrsample+eslsample
                    vousdoukas.int.probproj[,scenario,ii,slrmethod]<-c(mean(sssample),sqrt(var(sssample)),
                                                                quantile(sssample,prob=qs-qs[1]))
                    sssample<--slrsample+eslsample
                    rpssample<-RP(sssample/100,shapesample[1:ll],scalesample[1:ll],thresh[1:ll],lambda[1:ll])

                    vousdoukas.freq.probproj[,scenario,ii,slrmethod]<-c(mean(rpssample),sqrt(var(rpssample)),
                                                                 quantile(rpssample,prob=qs-qs[1],na.rm=TRUE))
                }
            }
        }
    }
}

save(list=c(objects(pattern="probproj"),objects(pattern="shape.scale.TWL.samples") ),file=filedir%&%"Rdatasets/RData_convolutions_fisherinfo_2100")
#note that by loading a different decade's data the same procedure creates convolutions for earlier times.

mm1<-match(dimnames(rl1r.diff.100.1)[[1]],dimnames(rl1k.diff.100.1)[[1]])
mm2<-match(dimnames(rl1r.diff.100.1)[[1]],dimnames(rl1v.diff.100.1)[[1]])
subsetrasmussen.all3<-seq(length(mm1))[!is.na(mm1)&!is.na(mm2)]
subsetrl1ktorasmussen<-mm1[subsetrasmussen.all3]
subsetrl1vtorasmussen<-mm2[subsetrasmussen.all3]

diffrasmussen<-rl1r.diff.100.1[subsetrasmussen.all3,]
diffkirezci<-rl1k.diff.100.1[subsetrl1ktorasmussen,]
diffvousdoukas<-rl1v.diff.100.1[subsetrl1vtorasmussen,]

TWL100.TWL1.diff.all3<-cbind(diffrasmussen,diffkirezci,diffvousdoukas)
dimnames(TWL100.TWL1.diff.all3)<-list(dimnames(rl1r.diff.100.1)[[1]][subsetrasmussen.all3],NULL)
temp<-rl1r[subsetrasmussen.all3,c("longitude","latitude")]
temp1<-apply(TWL100.TWL1.diff.all3,1,median,na.rm=TRUE)
temp2<-sqrt(apply(TWL100.TWL1.diff.all3,1,var,na.rm=TRUE))
TWL100.TWL1.diff.all3.stats<-as.matrix(cbind(temp,temp1,temp2))
dimnames(TWL100.TWL1.diff.all3.stats)<-list(dimnames(rl1r.diff.100.1)[[1]][subsetrasmussen.all3],c("longitude","latitude","median","stdev"))

mm3<-match(dimnames(rl1k.diff.100.1)[[1]],dimnames(rl1v.diff.100.1)[[1]])
subsetkirezci.all2<-seq(length(mm3))[!is.na(mm3)]
subsetrl1vtokirezci<-mm3[!is.na(mm3)]

diffkirezci<-rl1k.diff.100.1[subsetkirezci.all2,]
diffvousdoukas<-rl1v.diff.100.1[subsetrl1vtokirezci,]

TWL100.TWL1.diff.all2<-cbind(diffkirezci,diffvousdoukas)
dimnames(TWL100.TWL1.diff.all2)<-list(dimnames(rl1k.diff.100.1)[[1]][subsetkirezci.all2],NULL)
temp<-rl1k[subsetkirezci.all2,c("longitude","latitude")]
temp1<-apply(TWL100.TWL1.diff.all2,1,median,na.rm=TRUE)
temp2<-sqrt(apply(TWL100.TWL1.diff.all2,1,var,na.rm=TRUE))
TWL100.TWL1.diff.all2.stats<-as.matrix(cbind(temp,temp1,temp2))
dimnames(TWL100.TWL1.diff.all2.stats)<-list(dimnames(rl1k.diff.100.1)[[1]][subsetkirezci.all2],c("longitude","latitude","median","stdev"))

rm(diffrasmussen,diffkirezci,diffvousdoukas,tempdiff)

save(list=objects(pattern="diff"),file=filedir%&%"Rdatasets/RData_diff_TWL100_TWL1")


#' Used to replace duplicate scatterplots in a matrix
#'
#' @param x variable for x-axis
#' @param y variable for y-axis
#' @param digits rounding cut off
#' @param cex.cor type of point
#' @param include.p Include p-value for correlation value?
#' @param ... extra plotting parameters
#' @export
#' @examples data("iris")
#'   pairs(iris, upper.panel = panel.cor)
#'
panel.cor <- function(x, y, digits = 2, cex.cor, include.p = FALSE, ...)
{
  usr <- par("usr"); on.exit(par(usr))
  par(usr = c(0, 1, 0, 1))
  # correlation coefficient
  r <- cor(x, y)
  txt <- format(c(r, 0.123456789), digits = digits)[1]
  txt <- paste("r= ", txt, sep = "")
  text(0.5, 0.6, txt)

  if(include.p){
    # p-value calculation
    p <- cor.test(x, y)$p.value
    txt2 <- format(c(p, 0.123456789), digits = digits)[1]
    txt2 <- paste("p= ", txt2, sep = "")
    if(p<0.01) txt2 <- paste("p= ", "<0.01", sep = "")
    text(0.5, 0.4, txt2)
  }
}


bootstrap_samples = function( expected_I, observed_I, number_samples, window_size=3 , use_wa = FALSE, beta = 0.9){
  "
  Once the expected_I vector is computed is posible to generate the bootsrapped
  samples for  a confidence interval cosntruction.

  Parameters
  ----------
  Expected_I : numeric vector
    Number of sintomatic people on a given day (estimated).
  Observed_I : numeric vector
    Number of sintomatic people on a given day.
  number_samples : numeric
    number of samples.
  window_size : numeric
    smoothing factor.

  Returns
  -------
  standarized_residual : data_frame
    bootstrapped sample
  "
  standarized_residual <- standarized_residuals(expected_I, observed_I, window_size)
  samples = list()
  for( i in 1:number_samples)
  {
      sample <- sample(standarized_residual$SR, length(expected_I), replace = TRUE)

      if(use_wa){
        DES = 1:length(expected_I)
        temp_de = standarized_residual$DE
        for(j in 2:length(observed_I))
        {
          temp_de[j] = beta*temp_de[j - 1] + (1-beta)*temp_de[j]
        }
        sample = sample*temp_de
      }else{
        sample = sample*standarized_residual$DE
      }
      sample_I = expected_I + sample
      samples <- list.append(samples, i=sample_I)
  }
  df <- data.frame(matrix(unlist(samples), nrow=length(samples), byrow=T))
  return(df)
}

standarized_residuals = function(expected_I, observed_I, window_size=3){
"
  Residuals normalization for an umbaised bootstrap.

  Parameters
  ----------
  Expected_I : numeric vector
    Number of sintomatic people on a given day (estimated).
  Observed_I : numeric vector
    Number of sintomatic people on a given day.
  window_size : numeric
    smoothing factor.

  Returns
  -------
  standarized_residual : list
    SR : residuals
    DE : standard deviation
  "
  half_window_size = floor(window_size / 2)
  standarized_residual <- observed_I - expected_I
  DES = 1:length(expected_I)
  for( i in seq(half_window_size + 1, length(expected_I) - half_window_size + 1))
  {
    indices = (i-half_window_size):(i + half_window_size-1)
    DE = sd(observed_I[indices] - expected_I[indices])
    standarized_residual[i] = standarized_residual[i]/DE
    DES[i] = DE
  }

  first_window_idexes = 1:half_window_size
  last_window_indexes = (length(expected_I) - half_window_size + 1):length(expected_I)
  DE_in = sd(observed_I[first_window_idexes] - expected_I[first_window_idexes])
  DE_out = sd(observed_I[last_window_indexes] - expected_I[last_window_indexes])
  DES[first_window_idexes] = DE_in
  DES[last_window_indexes] = DE_out
  standarized_residual[first_window_idexes] = standarized_residual[first_window_idexes]/DE_in
  standarized_residual[last_window_indexes] = standarized_residual[last_window_indexes]/DE_out
  return(list("SR"=standarized_residual, "DE"=DES))
}

compute_variances = function(observed_I, window_size=3){
  "
  Residuals normalization for an umbaised bootstrap.

  Parameters
  ----------
  Expected_I : numeric vector
    Number of sintomatic people on a given day (estimated).
  Observed_I : numeric vector
    Number of sintomatic people on a given day.
  window_size : numeric
    smoothing factor.

  Returns
  -------
  standarized_residual : list
    SR : residuals
    DE : standard deviation
  "
  variance_observed = 1:length(observed_I)
  half_window_size = floor(window_size / 2)
  for( i in seq(half_window_size + 1, length(observed_I) - half_window_size + 1))
  {
    indices = (i-half_window_size):(i + half_window_size-1)
    variance = var(observed_I[indices])
    variance_observed[i] = variance
  }

  first_window_idexes = 1:half_window_size
  last_window_indexes = (length(observed_I) - half_window_size + 1):length(observed_I)
  DE_in = var(observed_I[first_window_idexes])
  DE_out = var(observed_I[last_window_indexes])
  variance_observed[first_window_idexes] = DE_in
  variance_observed[last_window_indexes] = DE_out
  return(variance_observed)
}


source("https://raw.githubusercontent.com/eogasawara/mylibrary/master/myTimeseries.R")

load_series <- function(name) {
  link <- url(sprintf("https://raw.githubusercontent.com/eogasawara/mylibrary/master/data/time-series/%s.RData", name))
  x <- get(load(link))
  return(x)
}

#==================== No decomposition ======================
train_test <- function(x, model, test_size=5, steps_ahead, sw_size=0) {

  ttx <- ts_train_test(x, test_size, sw_size)

  train <- ttx$train
  test <- ttx$test

  model <- ts_train(model, train)

  model <- ts_test(model, test, steps_ahead = steps_ahead)

  smape_test <- 100*model$test_smape
  smape_train <- 100*model$train_smape
  print(sprintf("%s %.2f%%", class(model)[1], 100*model$test_smape))

  ts_plot_series(c(model$train_value, model$test_value), model$train_pred, model$test_pred, class(model)[1])

  return(cbind(smape_train=smape_train,smape_test=smape_test))
}

#==================== EMD decomposition ======================
train_test_emd <- function(x, model, test_size=5, steps_ahead, sw_size=0) {
  #browser()

  #preprocess with EMD
  x_decomp <- emd(x, num_imfs=0, S_number=4L, num_siftings=50L, meaningfulImfs=NULL, h=1)

  pred <- list()

  for(imf in 1:length(x_decomp)){

    x_imf <- x_decomp[[imf]]

    ttx <- ts_train_test(x_imf, test_size, sw_size)

    x_train <- ttx$train
    x_test <- ttx$test

    model <- ts_train(model, x_train)
    model <- ts_test(model, x_test, steps_ahead = steps_ahead)

    pred[[imf]] <- c(model$train_pred,model$test_pred)
  }

  #postprocess the predictions
  pred <- emd.rev(pred)
  train_pred <- pred[1:(length(pred)-test_size)]
  test_pred <- tail(pred,test_size)

  train <- head(tail(x,length(pred)),length(pred)-test_size)
  test <- tail(x,test_size)

  smape_test <- TSPred::sMAPE(test, test_pred)*100
  smape_train <- TSPred::sMAPE(train, train_pred)*100
  print(sprintf("%s %.2f%%", class(model)[1], smape_test))

  ts_plot_series(c(train,test), train_pred, test_pred, class(model)[1])

  return(cbind(smape_train=smape_train,smape_test=smape_test))
}

#================= Wavelet transform decomposition ===================
train_test_wt <- function(x, model, test_size=5, steps_ahead, sw_size=0) {
  #browser()
  ttx <- ts_train_test(x, test_size)

  train <- ttx$train
  test <- ttx$test

  #preprocess with Wavelet transform
  x_decomp <- WaveletT(x,level=NULL,filter=c("haar", "d4", "la8", "bl14", "c6"),boundary="periodic",h=1)

  pred <- list()

  for(imf in 1:length(x_decomp)){
    x_imf <- x_decomp[[imf]]

    ttx <- ts_train_test(x_imf, test_size, sw_size)

    x_train <- ttx$train
    x_test <- ttx$test

    model <- ts_train(model, x_train)
    model <- ts_test(model, x_test, steps_ahead = steps_ahead)

    pred[[imf]] <- c(model$train_pred,model$test_pred)
  }

  #postprocess the predictions
  pred <- WaveletT.rev(pred=pred,attr(x_decomp,"wt_obj"))

  train_pred <- pred[1:(length(pred)-test_size)]
  test_pred <- tail(pred,test_size)

  train <- head(tail(x,length(pred)),length(pred)-test_size)
  test <- tail(x,test_size)

  smape_test <- TSPred::sMAPE(test, test_pred)*100
  smape_train <- TSPred::sMAPE(train, train_pred)*100
  print(sprintf("%s %.2f%%", class(model)[1], smape_test))

  ts_plot_series(c(train,test), train_pred, test_pred, class(model)[1])

  return(cbind(smape_train=smape_train,smape_test=smape_test))
}

x <- load_series("sin")

library(TSPred)
data("CATS")
x <- CATS[,1]

mdls <- list("ts_arima()")
funcs <- list("train_test","train_test_emd","train_test_wt")

benchmark_exp <- function(x,funcs,mdls,par){
  #browser()
  benchmark <- data.frame()
  for(f in funcs){
    for(mdl in mdls){
      res <- do.call(f,c(list(x),list(model=eval(parse(text=mdl))), c(par)))
      benchmark <- rbind(benchmark,cbind(func=f,model=mdl,res))
    }
  }
  return(benchmark)
}

benchmark_exp(x,funcs,mdls,list(test_size=5, steps_ahead = 5))

if (TRUE) {
  x <- load_series("sin")

  train_test(x, model=ts_arima(), test_size=5, steps_ahead = 5)
  train_test(x, model=ts_eelm_dir(4), test_size=5, steps_ahead = 5)
  train_test(x, model=ts_emlp_dir(4), test_size=5, steps_ahead = 5)

  preprocess <- ts_gminmax()
  require("e1071")
  train_test_wt(x, model=ts_nnet(preprocess, input_size=4), test_size=5, steps_ahead = 5, sw_size=10)
  train_test(x, model=ts_svm(preprocess, input_size=4), test_size=5, steps_ahead = 5, sw_size=10)
  train_test(x, model=ts_rf(preprocess, input_size=4), test_size=5, steps_ahead = 5, sw_size=10)
  train_test(x, model=ts_elm(preprocess, input_size=4), test_size=5, steps_ahead = 5, sw_size=10)
  train_test(x, model=ts_mlp(preprocess, input_size=4), test_size=5, steps_ahead = 5, sw_size=10)
  train_test(x, model=ts_tensor_cnn(preprocess, input_size=4), test_size=5, steps_ahead = 5, sw_size=10)
  train_test(x, model=ts_tensor_lstm(preprocess, input_size=4), test_size=5, steps_ahead = 5, sw_size=10)
}


expt = function(x) {
    if (length(x) > 1) {
        sapply(x, expt)
    } else {
        data = readBin(writeBin(x, raw(8)), "int", n=2)
        r = bitwShiftR(bitwAnd(data[2], 0x3ff00000), 20)
        if (r >= 512) {
            r = r-1024
        }
        return(r+1)
    }
}

mantissa = function(x) {
    if (length(x) > 1) {
        sapply(x, mantissa)
    } else {
        data = readBin(writeBin(x, raw(8)), "int", n=2)
        data[2] = bitwOr(bitwAnd(data[2], -0x7ff00001), 0x3ff00000)
        readBin(writeBin(data, raw(8)), "double")
    }
}

approxLog2 = function(x) {
    m = mantissa(x)
    expt(x) + ((6 * m - m * m) - 5)/3
}


 ZTBCON Example Program Results

 Estimate of condition number =  3.35E+01


context("Bounds")

test_that("rescale_mid returns correct results", {
  x <- c(-1, 0, 1)

  expect_equal(rescale_mid(x), c(0, 0.5, 1))
  expect_equal(rescale_mid(x, mid = -1), c(0.5, 0.75, 1))
  expect_equal(rescale_mid(x, mid = 1), c(0, 0.25, 0.5))

  expect_equal(rescale_mid(x, mid = 1, to = c(0, 10)), c(0, 2.5, 5))
  expect_equal(rescale_mid(x, mid = 1, to = c(8, 10)), c(8, 8.5, 9))
})

test_that("resacle_max returns correct results", {
  expect_equal(rescale_max(0), NaN)
  expect_equal(rescale_max(1), 1)
  expect_equal(rescale_max(.3), 1)
  expect_equal(rescale_max(c(4, 5)), c(0.8, 1.0))
  expect_equal(rescale_max(c(-3, 0, -1, 2)), c(-1.5, 0, -0.5, 1))
})

test_that("zero range inputs return mid range", {
  expect_that(rescale(0), equals(0.5))
  expect_that(rescale(c(0, 0)), equals(c(0.5, 0.5)))
})

test_that("censor and squish ignore infinite values", {
  expect_equal(squish(c(1, Inf)), c(1, Inf))
  expect_equal(censor(c(1, Inf)), c(1, Inf))

})


# Master Thesis Project - Extreme Value Theory
# Plotting a sample of the Brownian Motions
# Killian Martin--Horgassan
# 23-04-2015

# Clear the environment
rm(list=ls())

# Close all already open graphic windows
graphics.off()

# Sourcing the auxiliary files
source("/Users/kimartin/Desktop/R_files_pdm/Tache5/randomWalk.r")
source("/Users/kimartin/Desktop/R_files_pdm/Tache5/Epsilon_is.r")
source("/Users/kimartin/Desktop/R_files_pdm/Tache5/brokenLine.r")
source("/Users/kimartin/Desktop/R_files_pdm/Tache5/brownianMotion.r")

# Let the user enter the time horizon of the brownian motion
cat("Time step ?")
t <- as.numeric(readline("t :\n"))

# t itself will be divided in increments
cat("Increment size ?")
h <- as.numeric(readline("h :\n"))

# Number of increments
Nb_incr <- ceiling(t/h)

# Generating the Brownian Motion
BM_vect <- brownianMotion(t,h)

# Plot the Brownian Motion
quartz()

title <- paste("A brownian motion of time horizon t", t, "with increment h", h, sep = " ")
xlabel <- paste("Time t in", expression(h^-1),"time units", sep= " ")
ylabel <- expression(B[t]^(n))

plot(BM_vect,xlab = xlabel, ylab = ylabel, main = title, type ='l')
abline(h = 0, col = "red")


library(keras)

max_features <- 2000 #20000
batch_size <- 32
epochs = 5

# Cut texts after this number of words (among top max_features most common words)
maxlen <- 80

cat('Loading data...\n')
imdb <- dataset_imdb(num_words = max_features)
x_train <- imdb$train$x
y_train <- imdb$train$y

x_test <- imdb$test$x
y_test <- imdb$test$y

cat(length(x_train), 'train sequences\n')
cat(length(x_test), 'test sequences\n')

cat('Pad sequences (samples x time)\n')
x_train <- pad_sequences(x_train, maxlen = maxlen)
x_test <- pad_sequences(x_test, maxlen = maxlen)

##small sample size
#x_train <- x_train[1:5000,]
#y_train <- y_train[1:5000]

cat('x_train shape:', dim(x_train), '\n')
cat('x_test shape:', dim(x_test), '\n')

cat('Build model...\n')
model <- keras_model_sequential()
model %>%
    layer_embedding(input_dim = max_features, output_dim = 128) %>%
    layer_lstm(units = 64, dropout = 0.2, recurrent_dropout = 0.2) %>%
    layer_dense(units = 1, activation = 'sigmoid')

# Try using different optimizers and different optimizer configs
model %>% compile(
    loss = 'binary_crossentropy',
    optimizer = 'adam',
    metrics = c('accuracy')
)

cat('Train...\n')
model %>% fit(
    x_train, y_train,
    batch_size = batch_size,
    epochs = epochs,
    validation_split = 0.3
)

y_pred<-predict(model, x_test)
pROC::roc(y_test,y_pred )

scores <- model %>% evaluate(
    x_test, y_test,
    batch_size = batch_size
)

cat('Test score:', scores[[1]])
cat('Test accuracy', scores[[2]])


Args<-commandArgs()
in_file<-Args[6]
gene_stat_file<-Args[7]

data<-read.table(in_file, header=T, com='', sep="\t")

d<-data[,4:length(data)]
mat<-as.matrix(d) # convert to matrix
mat<-t(mat)

colnames(mat)<-data[,3]
mat <- log2(mat+1)
sd_gene <- apply(mat, 2, sd)
mat <- mat[,which(sd_gene!=0)]
mean_gene <- apply(mat, 2, mean)
median_gene <- apply(mat, 2, median)
sd_gene <- sd_gene[which(sd_gene!=0)]
#scaled_mat <- (mat - median_gene)/sd_gene
#scaled_mat <- mat - median_gene
#scaled_mat <- mat

gene_stat <- cbind(as.matrix(mean_gene),as.matrix(sd_gene),as.matrix(median_gene))
colnames(gene_stat)<-c("mean","sd","median")
write.table(gene_stat, file=gene_stat_file, sep='\t', col.names=TRUE);
#write.table(scaled_mat, file=gene_stat_file, sep='\t', col.names=FALSE);


#' f_qscop
#'
#' Estimate the quantile given specific $(\tau, x)$
#'
#' @param tau conditional probability
#' @param n1 the first covariates
#' @param til_beta the current estimation fro $\tilde{\beta}$
#' @param m_sigma $K_\tau K_1 \times K_\tau K_1 \Sigma$ diagonal block matix.
#' @param ktau internal knots of tau
#' @param mtau order for tau spline
#'
#'
#' @return An estimated the quantile given specific $(\tau, x)$
#'
#' @examples
#' \dontrun{
#' k1 <- 4; ktau <- 4; m1 <- 4; mtau <- 4; y <- rnorm(200)
#' n1 <- f_n1(1:200, k1, m1); beta <- rnorm(prod(ktau + mtau, k1 + m1))
#' til_beta <- tilde_beta(beta, k1 + m1)
#' m_sigma <- f_sigma(ktau + mtau, k1 + m1)
#' f_qscop(seq(0, 1, 0.1), n1, til_beta, m_sigma, ktau, mtau)
#' f_qscop(0, n1, til_beta, m_sigma, ktau, mtau) < f_qscop(1, n1, til_beta, m_sigma, ktau, mtau)

#' }

f_qscop <- function(tau, n1, til_beta, m_sigma, ktau, mtau) {
    m_n <- kronecker(spline_basis(tau, ktau, mtau, c(1, 0)), n1)
    out <- m_n %*% m_sigma %*% til_beta
    return(c(out))
}

#' f_qzeros
#'
#' zeros function to find the root $\tau_i$ for each observs
#'
#' @param tau conditional probability
#' @param idx index of the observations
#' @param v_y vector of y
#' @param n1 spline basis for the first covariates
#' @param ... other 4 args for f_qscop in order (til_beta, m_sigma, ktau, mtau)
#'
#'
#' @return Difference bw response and estimation $Q(\tau, x_i) - y_i$
#'
#' @examples
#' \dontrun{
#' k1 <- 4; ktau <- 4; m1 <- 4; mtau <- 4; y <- rnorm(200)
#' n1 <- f_n1(1:200, k1, m1); beta <- rnorm(prod(ktau + mtau, k1 + m1))
#' til_beta <- tilde_beta(beta, k1 + m1)
#' m_sigma <- f_sigma(ktau + mtau, k1 + m1)
#' f_qzeros(0.5, 2:3, y, n1, til_beta, m_sigma, ktau, mtau)
#' }
f_qzeros <- function(tau, idx, v_y, n1, ...) {
    n1 <- n1[idx, ]
    if (length(idx) == 1) {
        n1 <- t(n1)
    }
    s_dif <- f_qscop(tau, n1, ...) - v_y[idx]
    if ((tau == 0 && s_dif > 0) || (tau == 1 && s_dif < 0)) {
        return(0)
    }

    return(s_dif)
}

#' f_tausearch
#'
#' search the $\tau^*$ using the unitroot function
#'
#' @param v_y vector of y
#' @param n1 spline basis for the first covariates
#' @param ... other 4 args for f_qscop in order (til_beta, m_sigma, k2, m2)
#'
#'
#' @return $\tau^*$
#'
#' \dontrun{
#' k1 <- 4; ktau <- 4; m1 <- 4; mtau <- 4; y <- rnorm(200)
#' n1 <- f_n1(1:200, k1, m1); beta <- rnorm(prod(ktau + mtau, k1 + m1))
#' til_beta <- tilde_beta(beta, k1 + m1)
#' m_sigma <- f_sigma(ktau + mtau, k1 + m1)
#' f_qzeros(0.5, 2:3, y, n1, til_beta, m_sigma, ktau, mtau)
#' v_taus <- f_tausearch(y, n1, til_beta, m_sigma, ktau, mtau)
#' sapply(1:200, function(x) {
#'      f_qscop(v_taus[x], t(n1[x, ]), til_beta, m_sigma, ktau, mtau)
#' }) - y
#' }
f_tausearch <- function(v_y, n1, ...) {
    taustar <- sapply(seq_along(v_y), function(x) {
                    uniroot(f_qzeros,
                            idx = x,
                            v_y = v_y,
                            n1 = n1,
                            ...,
                            interval = c(0, 1))$root})
    return(taustar)
}


library(epimdr)
library(fields)

data(black)
black

b2 = black[-c(1,8,9),]  #subsetting age brackets
#Estimate log-FoI
fit = glm(cbind(pos,neg) ~ offset(log(mid)),
    family = binomial(link = "cloglog"), data = b2)
#Plot predicted and observed
phi = exp(coef(fit))
curve(1-exp(-phi*x), from = 0, to = 60,
     ylab = "Seroprevalence", xlab = "Age")
points(black$mid, black$f, pch = "*", col = "red")
points(x = b2$mid, y = b2$f, pch = 8)
exp(fit$coef)

data(rabbit)
head(rabbit)

rabbit$notinf = rabbit$n - rabbit$inf
#Binomial regression
fit = glm(cbind(inf, notinf) ~ offset(log(a)),
    family = binomial(link = "cloglog"),
    data = rabbit, subset = a<12)
#Plot data
symbols(rabbit$inf/rabbit$n ~ rabbit$a, circles = rabbit$n,
     inches = 0.5, xlab = "Age", ylab = "Prevalence")
#Predicted curves for <1 and all
phi = exp(coef(fit))
curve(1-exp(-phi*x), from = 0, to = 12, add = TRUE)
curve(1-exp(-phi*x), from = 0, to = 30, add = TRUE, lty = 2)
1/phi

integrandpc = function(a, up, foi){
  #Find which interval a belongs to
  wh = findInterval(a, sort(c(0,up)))
  #Calculate duration of each interval
  dur = diff(sort(c(0,up)))
  #Evaluate integrand
  inte = ifelse(wh == 1, foi[1]*a,
       sum(foi[1:(wh-1)]*dur[1:(wh-1)])+
          foi[wh]*(a-up[wh-1]))
  return(inte)
}

llik.pc = function(par, age, num, denom, up) {
    ll = 0
    for (i in 1:length(age)) {
       p = 1 - exp(-integrandpc(a=age[i], up = up,
          foi = exp(par)))
       ll = ll + dbinom(num[i], denom[i], p, log = T)
    }
return(-ll)
}

x = c(1, 4, 8, 12, 18, 24, 30)
para = rep(0.1, length(x))

est = optim(par=log(para),fn=llik.pc, age=rabbit$a,
     num=rabbit$inf,  denom=rabbit$n, up=x,
     method="Nelder-Mead", control=list(trace=2))

round(exp(est$par), 4)

#Make space for left and right axes
par(mar = c(5,5,2,5))
#Add beginning and ends to x and y for step plot
xvals=c(0,x)
yvals=exp(c(est$par, est$par[7]))
plot(xvals, yvals, type="s", xlab="age", ylab="FoI")

#Superimpose predicted curve
par(new=T)
p = rep(0, 28)
for (i in 1:28) {
     p[i] = 1 - exp(-integrandpc(a=i, up = x,
        foi = exp(est$par)))
}
plot(p~c(1:28), ylim=c(0,1), type="l", col="red",
     axes=FALSE, xlab=NA, ylab=NA)

#Add right axis and legend
axis(side = 4)
mtext(side = 4, line = 4, "Prevalence")
legend("right", legend=c("FoI", "Prevalence"),
     lty=c(1,1), col=c("black", "red"))

require(splines)
# Degrees-of-freedom
df = 7
# Construct dummy lm-object
dl = lm(inf ~ bs(a, df), data = rabbit)

tmpfn = function(x, dl) {
    x = predict(dl, newdata = data.frame(a = x))
    exp(x)
}

tmpfn2 = function(par, data, df){
   #Dummy lm-object
   dl = lm(inf ~ bs(a,df), data = data)
   #Overwrite spline coefficients with new values
   dl$coefficients = par
   #Calculate log-likelihood
   ll = 0
   for(i in 1:length(data$a)){
     p = 1 - exp(-integrate(tmpfn, 0, i, dl = dl)$value)
     ll = ll + dbinom(data$inf[i], data$n[i], p ,log = T)
   }
 return(-ll)
 }

options(warn=-1)
para = rep(-1, df + 1)
dspline = optim(par = para, fn = tmpfn2, data = rabbit,
     df = df, method = "Nelder-Mead", control =
     list(trace = 2, maxit = 2000))
options(warn=0)

options(warn=-1)
par(mar = c(5, 5, 2, 5)) #Room for two axes
#Overwrite dummy-objects coefficients with MLEs
dl$coefficients = dspline$par
#Age-prevalce plot
plot(tmpfn(rabbit$a,dl) ~ rabbit$a, type = "l", ylab = "FoI",
     xlab = "Age (mos)", las = 1)
#Overlay FoI
par(new = TRUE)
p = rep(0, 28)
for (i in 1:28) {
     p[i] = 1 - exp(-integrate(tmpfn, 0, i,
          dl = dl)$value)
}
plot(p ~ c(1:28), ylim = c(0,1), type = "l", col = "red",
     axes = FALSE, xlab = NA, ylab = NA)
axis(side = 4, las = 1)
mtext(side = 4, line = 4, "Prevalence")
legend("topright", legend = c("FoI", "Prevalence"),
     lty = c(1,1), col = c("black", "red"))
options(warn=0)

data(peru)
head(peru)
#Calculate cumulative incidence
peru$cumulative=cumsum(peru$incidence)
#Define denominator
peru$n=sum(peru$incidence)
par(mar = c(5,5,2,5)) #Make room for two axes and plot
#Plot incidence with cumulative overlaid
plot(peru$incidence~peru$age, type="b", xlab="Age",
     ylab="Incidence")
par(new=T)
plot(peru$cumulative~peru$age, type="l", col="red",
     axes=FALSE, xlab=NA, ylab=NA)
axis(side = 4)
mtext(side = 4, line = 4, "Cumulative")
legend("right", legend=c("Incidence", "Cumulative"),
     lty=c(1,1), col=c("black", "red"))

#Upper age cut-offs
up = c(1:20, 30, 40, 50, 60, 70,100)
para = rep(.1, length(up)) #Inital values
#Minimize log-likelihood
est2 = optim(par = log(para),fn = llik.pc, age = peru$age,
     num = peru$cumulative, denom = peru$n, up = up,
     method = "Nelder-Mead", control =
     list(trace = 2, maxit = 2000))
#Step plot
x = c(0, up)
y = exp(c(est2$par, est2$par[26]))
plot(x, y, ylab = "Relative FoI", xlab = "Age", type = "s",
     ylim = c(0, 0.25), xlim = c(0, 80))

data3 = peru[peru$age < 45, ]
df = 5
para = rep(0.1, df + 1)

#Prediction function
tmpfn=function(x,dl){
    x=predict(dl, newdata=data.frame(age=x))
exp(x)}
#Dummy lm-object
dl=lm(cumulative~bs(age,df), data=data3)
#Log-likelihood function
tmpfn2=function(par,data, df){
    dl=lm(cumulative~bs(age,df), data=data)
    dl$coefficients=par
    ll=0
    for(a in 1:length(data$age)){
      p=((1-exp(-integrate(tmpfn,0,data$age[a],
         dl=dl)$value)))
      ll=ll+dbinom(data$cumulative[a],data$n[a],p,log=T)
    }
 return(-ll)
 }

#Fit model
options(warn=-1)
dspline.a45.df5=optim(par=log(para),fn=tmpfn2,
     data=data3, df=df, method="Nelder-Mead",
     control=list(trace=4, maxit=5000))
#Overwrite dummy-objects coefficients with MLEs
dl$coefficients=dspline.a45.df5$par
plot(exp(predict(dl))~data3$age, xlab="Age",
     ylab="Relative FoI", type="l")
options(warn=0)

(exp(-integrate(tmpfn,0,15,dl=dl)$value))*(1-
     exp(-integrate(tmpfn,15,40,dl=dl)$value))

redn=0.5
(exp(-redn*integrate(tmpfn,0,15,dl=
     dl)$value))*(1-exp(-redn*integrate(tmpfn,
     15,40,dl=dl)$value))

data(mossong)
head(mossong)
x=y=mossong$contactor[1:30]
z=matrix(mossong$contact.rate, ncol=30, nrow=30)
image(x=x, y=y, z=z, xlab="Contactor",
     ylab="Contactee", col=gray((12:32)/32))
contour(x=x, y=y, z=z, add=TRUE)

plot(apply(z,1,mean)~x, ylab="Total contact rate",
     xlab="Age")

a = c(1/diff(x), 0)

n = length(x)
z2 = (z + t(z))/2
z3 = as.vector(z2)
xy = data.frame(x = rep(x[1:n], n), y = rep(y[1:n], each = n))
polysmooth = Tps(xy, z3, df = 100)
surface(polysmooth, xlab = "", ylab = "",
     col=gray((12:32)/32))

W = matrix(polysmooth$fitted.values[,
     1]/mean(polysmooth$fitted.values), nrow = n)

siragemod = function(t, logx,  params){
     n=length(params$a)
     x = exp(logx)
     S = x[1:n]
     I = x[(n+1):(2*n)]
     R = x[(2*n+1):(3*n)]
     with(as.list(params), {
          phi = (beta*W%*%I)/N
          dS = c(mu,rep(0,n-1)) - (phi+a)*S +
              c(0,a[1:n-1]*S[1:n-1])*(1-p) - mu*S
          dI = phi*S + c(0,a[1:n-1]*I[1:n-1]) -
             (gamma+a)*I - mu*I
          dR =  c(0,a[1:n-1]*S[1:n-1])*p +
             c(0,a[1:n-1]*R[1:n-1]) + gamma*I -
             a*R - mu*R
     res = c(dS/S, dI/I, dR/R)
     list((res))
     })
}

p.pre = rep(0,n)
pars.pre = list(N = 1, gamma = 365/14, mu = 0.02, sigma = 0.2,
     beta = 100, W = W,p = p.pre, a = a)
ystart = log(c(S = rep(0.099/n,n), I = rep(0.001/n,n),
     R = rep(0.9/n,n)))

times = seq(0, 500, by = 14/365)
#Polymod mixing
out=as.data.frame(ode(ystart, times=times,
     func = siragemod, parms = pars.pre))
par(mfrow = c(1,2)) #Room for side-by-side plots
#Time series
matplot(times, exp(out[,32:61]), type = "l", xlab = "Time",
    ylab = "Prevalence", xlim = c(50, 90), ylim = c(0, 0.0005))
#Final age-prevalence curve
plot(x, t(exp(out[13036, 32:61])*a), ylab = "Prevalence",
    xlab = "Age", ylim = c(0, 4E-5))
#Homogenous mixing:
pars.pre$W = matrix(1, ncol = 30, nrow = 30)
out2=as.data.frame(ode(ystart, times=times,
    func=siragemod, parms=pars.pre))
points(x, t(exp(out2[13036,32:61])*a), col=2, pch="*")


# H0: BGP == TripleBGP
# Compare means with one-way ANOVA

## Bloom
data <- read.csv('../../results/filter_types/plot_all.csv', sep = ';')
t.test(data$combination_2, data$combination_6,paired=TRUE)
# p: 0.5145
# => Accept H0, equal means
mean(data$combination_2) # 12284.03
mean(data$combination_6) # 16931.79
# BGP == Triple !

## GCS
data <- read.csv('../../results/filter_types/plot_all.csv', sep = ';')
t.test(data$combination_3, data$combination_7,paired=TRUE)
# p: 0.6197
# => Accept H0, equal means
mean(data$combination_3) # 12582.91
mean(data$combination_7) # 16145.12
# BGP == Triple !


library(mltools)
library(proxy)
library(textshape)
library(tidyr)
setwd("/Users/ryanc/Documents/Pink_pigeon/RADIKal_v2/2020Aug/FINAL_RADIKAL/All_scores_info/")
df <- read.csv("ALL_scores_info.csv", header = F, sep=" ")
df<- df[!(df$V4 <= 0),]
df[, "binme"] <- bin_data(df$V4, bins=10, binType = "quantile")

bins <- c(0.000214359356167648,35.4873191237245, 65.6608760600881, 87.4509361085066,
          102.441368790823, 115.551631313013, 137.093693977965, 158.511351118823,
  173.198888010529, 186.346588587725, 232.537542948543)


context("Check accuracy of LIML using Card data")

test_that("TSLS = LIML when you have single IV", {
  Y=card.data[,"lwage"]
  D=card.data[,"educ"]
  Z=card.data[,"nearc4"]

  # No covar, no intercept
  foo = ivmodel(Y=Y,D=D,Z=Z,intercept=FALSE)
  tsls_output = as.numeric(coef(foo)["TSLS",])
  LIML_output = as.numeric(coef(foo)["LIML",])
  expect_equal(tsls_output,LIML_output)

  # No covar, intercept
  foo = ivmodel(Y=Y,D=D,Z=Z)
  tsls_output = as.numeric(coef(foo)["TSLS",])
  LIML_output = as.numeric(coef(foo)["LIML",])
  expect_equal(tsls_output,LIML_output)
  expect_equal(coefOther(foo)$TSLS,coefOther(foo)$LIML)

  # Covar, no intercept
  Xname=c("exper", "expersq", "black", "south", "smsa", "reg661",
          "reg662", "reg663", "reg664", "reg665", "reg666", "reg667",
          "reg668", "smsa66")
  X=card.data[,Xname]

  foo = ivmodel(Y=Y,D=D,Z=Z,X=X,intercept=FALSE)
  tsls_output = as.numeric(coef(foo)["TSLS",])
  LIML_output = as.numeric(coef(foo)["LIML",])
  expect_equal(tsls_output,LIML_output)
  expect_equal(coefOther(foo)$TSLS,coefOther(foo)$LIML)

  # Covar, intercept
  foo = ivmodel(Y=Y,D=D,Z=Z,X=X)
  tsls_output = as.numeric(coef(foo)["TSLS",])
  LIML_output = as.numeric(coef(foo)["LIML",])
  expect_equal(tsls_output,LIML_output)
  expect_equal(coefOther(foo)$TSLS,coefOther(foo)$LIML)
})

test_that("LIML estimate without exogeneous covariates, mult-IV", {
  Y=card.data[,"lwage"]
  D=card.data[,"educ"]
  Z=card.data[,c("nearc4","nearc2")]

  foo = ivmodel(Y=Y,D=D,Z=Z,intercept=FALSE)
  est_out = as.numeric(coef(foo)["LIML",])
  expect_equal(est_out,c(1.00142462444e+00,4.67565741669e-01,1.88656148938e-03,2.47840181357e+02,0.00000000000e+00))

  foo = ivmodel(Y=Y,D=D,Z=Z)
  est_out = as.numeric(coef(foo)["LIML",])
  expect_equal(est_out,c(1.00110965158e+00, 2.06278670996e-01, 2.79605430592e-02, 7.37749158014e+00, 2.07611705605e-13))
  est_other_out = as.numeric(coefOther(foo)$LIML)
  expect_equal(est_other_out,c(3.525864054210,0.371009242718,9.503439936918,0))

})

test_that("LIML estimate with exogenous covariates, multi-IV", {
  Y=card.data[,"lwage"]
  D=card.data[,"educ"]
  Z=card.data[,c("nearc4","nearc2")]
  Xname=c("exper", "expersq", "black", "south", "smsa", "reg661",
          "reg662", "reg663", "reg664", "reg665", "reg666", "reg667",
          "reg668", "smsa66")
  X=card.data[,Xname]

  foo = ivmodel(Y=Y,D=D,Z=Z,X=X,intercept=FALSE)
  est_out = as.numeric(coef(foo)["LIML",])
  expect_equal(est_out,c(1.000859911203,0.331859012784,0.012046871349,27.547319396786, 0))
  est_other_out = coefOther(foo)$LIML
  resulting_val = c(0.23364183864109, 0.02021057771855, 11.560374072169, 0,
                   -0.00436821301809, 0.00110332841567, -3.959123100652, 7.69751447831e-05,
                    0.03312459166842, 0.03308960347837,  1.001057377133, 3.16879939962e-01,
                   -0.12105392121076, 0.04407730255489, -2.746400396440, 6.06133942841e-03,
                    0.06046339337471, 0.04137629128184,  1.461305291063, 1.44036581582e-01,
                    0.05087023578479, 0.08929079929188,  0.569714194388, 5.68914289109e-01,
                    0.16757963517009, 0.07661009933952,  2.187435293974, 2.87878235965e-02,
                    0.21488920113501, 0.07673872120887,  2.800270811786, 5.13871753283e-03,
                    0.10306279640681, 0.09436296666945,  1.092195381773, 2.74835079485e-01,
                    0.26499409700390, 0.08435145473479,  3.141547443812, 1.69697892460e-03,
                    0.30606352407280, 0.09210857765334,  3.322855828094, 9.01715695532e-04,
                    0.23692819629421, 0.08507584157808,  2.784905701776, 5.38798821139e-03,
                   -0.12131904963092, 0.10436146853516, -1.162488908347, 2.45129548098e-01,
                    0.01642425108771, 0.03593975566316,  0.456993955152, 6.47708533398e-01)
  resulting_val = matrix(resulting_val,length(Xname),4,byrow=TRUE)
  colnames(resulting_val) = c("Estimate","Std. Error","t value","Pr(>|t|)")
  rownames(resulting_val) = Xname
  expect_equal(est_other_out,resulting_val)

  foo = ivmodel(Y=Y,D=D,Z=Z,X=X)
  est_out = as.numeric(coef(foo)["LIML",])
  expect_equal(est_out,c(1.0004094273165,0.1640277561000,0.0554950702135,2.9557176064271,0.0031437760692))
  est_other_out = coefOther(foo)$LIML
  resulting_val = c(0.12168991721364, 0.023982112015946,  5.0741951806718, 4.12895895474e-07,
                   -0.00236235860783, 0.000352513445745, -6.7014709264197, 2.45576892155e-11,
                   -0.11687046279985, 0.054741901014118, -2.1349361391325, 3.28471930607e-02,
                   -0.14279170805679, 0.028847823460314, -4.9498260502471, 7.83906274560e-07,
                    0.09773848045461, 0.032643225029197,  2.9941429000103, 2.77469235253e-03,
                   -0.10165672445578, 0.044113721055252, -2.3044241570203, 2.12669732909e-02,
                    0.00163040341363, 0.034504112804948,  0.0472524369151, 9.62315187055e-01,
                    0.04873104057901, 0.033329378391302,  1.4621046935496, 1.43817473876e-01,
                   -0.05472430780333, 0.039747947181537, -1.3767832475320, 1.68682209993e-01,
                    0.05506160552795, 0.048860435931131,  1.1269159695088, 2.59868319889e-01,
                    0.07406188766618, 0.054781913834350,  1.3519404942683, 1.76496469376e-01,
                    0.04241390943707, 0.050976830315037,  0.8320232775352, 4.05462161154e-01,
                   -0.19998558533462, 0.053429008023303, -3.7430151285495, 1.85242733723e-04,
                    0.01411679795615, 0.022738627996378,  0.6208289241724, 5.34759446929e-01,
                    3.22126944354386, 0.944077217813185,  3.4120825953257, 6.53239525561e-04)
  resulting_val = matrix(resulting_val,length(Xname)+1,4,byrow=TRUE)
  colnames(resulting_val) = c("Estimate","Std. Error","t value","Pr(>|t|)")
  rownames(resulting_val) = c(Xname,"intercept")
  expect_equal(est_other_out,resulting_val)

})


 E04NFJ Example Program Results

 *** e04nf

 Parameters
 ----------

 Problem type...........       QP2

 Linear constraints.....         7       Feasibility tolerance..  1.05E-08
 Variables..............         7       Optimality tolerance...  1.05E-08
 Hessian rows...........         7       Rank tolerance.........  1.11E-14

 Infinite bound size....  1.00E+20       COLD start.............
 Infinite step size.....  1.00E+20       EPS (machine precision)  1.11E-16

 Check frequency........        50       Expand frequency.......         5
 Minimum sum of infeas..        NO       Crash tolerance........  1.00E-02

 Max degrees of freedom.         7       Print level............        10
 Feasibility phase itns.        70       Monitoring file........        -1
 Optimality  phase itns.        70

 Workspace provided is     IWORK(      17),  WORK(     189).
 To solve problem we need  IWORK(      17),  WORK(     189).

  Itn     Step Ninf Sinf/Objective  Norm Gz
    0  0.0E+00    3   1.038000E-01  0.0E+00
    1  4.1E-02    1   3.000000E-02  0.0E+00
    2  4.2E-02    0   0.000000E+00  0.0E+00
 Itn     2 -- Feasible point found.
    2  0.0E+00    0   4.580000E-02  0.0E+00
    3  1.3E-01    0   4.161596E-02  0.0E+00
    4  1.0E+00    0   3.936227E-02  4.2E-17
    5  4.1E-01    0   3.758935E-02  1.2E-02
    6  1.0E+00    0   3.755377E-02  1.0E-17
    7  1.0E+00    0   3.703165E-02  3.8E-17

 Varbl State     Value       Lower Bound   Upper Bound    Lagr Mult   Slack

 V   1    LL  -1.000000E-02 -1.000000E-02  1.000000E-02  0.4700         .
 V   2    FR  -6.986465E-02 -0.100000      0.150000           .      3.0135E-02
 V   3    FR   1.825915E-02 -1.000000E-02  3.000000E-02       .      1.1741E-02
 V   4    FR  -2.426081E-02 -4.000000E-02  2.000000E-02       .      1.5739E-02
 V   5    FR  -6.200564E-02 -0.100000      5.000000E-02       .      3.7994E-02
 V   6    FR   1.380544E-02 -1.000000E-02      None           .      2.3805E-02
 V   7    FR   4.066496E-03 -1.000000E-02      None           .      1.4066E-02

 L Con State     Value       Lower Bound   Upper Bound    Lagr Mult   Slack

 L   1    EQ  -0.130000     -0.130000     -0.130000      -1.908     -5.5511E-17
 L   2    FR  -5.879898E-03      None     -4.900000E-03       .      9.7990E-04
 L   3    UL  -6.400000E-03      None     -6.400000E-03 -0.3144      8.6736E-19
 L   4    FR  -4.537323E-03      None     -3.700000E-03       .      8.3732E-04
 L   5    FR  -2.915996E-03      None     -1.200000E-03       .      1.7160E-03
 L   6    LL  -9.920000E-02 -9.920000E-02      None       1.955         .
 L   7    LL  -3.000000E-03 -3.000000E-03  2.000000E-03   1.972      4.3368E-18

 Exit e04nf  - Optimal QP solution.

 Final QP objective value =   0.3703165E-01

 Exit from QP problem after     7 iterations.


hist_nwj <- function(x, type='nwj', alpha=0.01, P=0.99, breaks=NULL, jfit='all',
                     upperbound=TRUE, main=NULL, subtitle='yes', suppress='no') {
    ## plot histogram and normal, Weibull, and Johnson distributions
    ## adds lines for upper tolerance limits for given alpha and proportion
    ## alpha  = 1 - confidence
    ## P = coverage proportion (tolerance interval only)
    proportion = P
    ## breaks = number of bins used in the histogram (default auto determines number)
    ## jfit  = 'all' = uses SuppDists::JohnsonFit to determine parameters
    ##       = 'SU'  = uses ExtDist::eJohnsonSU to determine parameters
    ##       = list of user specified parameters
    ##         e.g., jparms <- list(gamma   = -1.039,
    ##                              delta   = 1.66,
    ##                              xi      = 14.46,
    ##                              lambda  = 6.95,
    ##                              type    = 'SU')
    ##              johnson_tol(mtcars$mpg, jfit=jparms)
    ## main = title for histogram (default is "Histogram of ...")
    ## subtitle = 'yes' = puts description of lines in subtitle
    ##          = 'no'  = subtitle is blank
    ##          = user specified, single line subtitle
    ## suppress = 'yes' creates plot but does not return calculated values to the screen
    ##            (e.g., fit parameters and tolerance limits)

    ## name of variable passed in
    xname <- deparse(substitute(x))

    ## initialize parameters
    xmean <- NA
    xsd   <- NA
    shape <- NA
    scale <- NA
    jparms <- NA
    tol_out_norm <- NA
    tol_out_weib <- NA
    tol_out_john <- NA
    upper_tolerance_limit_norm <- NA
    upper_tolerance_limit_weib <- NA
    upper_tolerance_limit_john <- NA
    xdensity_norm <- NA
    xdensity_weib <- NA
    xdensity_john <- NA

    if (grepl('n', type)) {
        ## normal distribution calculations
        tol_out_norm <- tolerance::normtol.int(x, alpha = alpha, P=proportion, side=1)
        upper_tolerance_limit_norm <- tol_out_norm$'1-sided.upper'
    }

    if (grepl('w', type)) {
        ## Weibull distribution calculations
        if (min(x) < 0) {
            cat('\n')
            cat('#####################################################################\n')
            cat('Skip Weibull: Negative values cannot be fit with Weibull distribution\n')
            cat('#####################################################################\n\n')
            tol_out_weib <- NA
            shape <- NA
            scale <- NA
            upper_tolerance_limit_weib <- NA
        } else {
            tol_out_weib <-  tolerance::exttol.int(x, alpha=alpha, P=proportion, side=1, dist="Weibull")
            shape   <- tol_out_weib$'shape.1'
            scale   <- tol_out_weib$'shape.2'
            upper_tolerance_limit_weib <- tol_out_weib$'1-sided.upper'
        }
    }

    if (grepl('j', type)) {
        ## Johnson distribution calculations
        tol_out_john <- johnson_tol(x, alpha=alpha, P=proportion, side=1, jfit=jfit)
        jparms   <- tol_out_john$jparms
        upper_tolerance_limit_john <- tol_out_john$xtol_upper
    }

    ## create vectors with density distributions
    xmin    <- min(x)
    if (isTRUE(upperbound)) {
        xmax <- max(x,
                    upper_tolerance_limit_norm,
                    upper_tolerance_limit_weib,
                    upper_tolerance_limit_john,
                    na.rm = TRUE)
    } else {
        xmax <- max(x, na.rm = TRUE)
    }
    chuncks <- (xmax-xmin)/1000
    xrange  <- seq(xmin,xmax,by=chuncks)
    xmean   <- mean(x)
    xsd     <- sd(x)
    if (grepl('n', type)) xdensity_norm <- stats::dnorm(xrange,xmean,xsd)
    if (grepl('w', type)) xdensity_weib <- stats::dweibull(xrange,shape=shape,scale=scale)
    if (grepl('j', type)) xdensity_john <- SuppDists::dJohnson(xrange, jparms)

    ## make histogram
    ## warning: xlim range can mess up x-axis
    ## obtain histogram parameters but suppress plot
    if (is.null(breaks)) {
        ## breaks not specified so figure out what to use
        out <- hist(x, plot=FALSE)
        breaks <- length(out$breaks)
    }
    ## hist needed with number of breaks to be used to get density for max height of histogram
    out <- hist(x, breaks=breaks, plot=FALSE)
    maxdensity <- max(xdensity_norm, xdensity_weib, xdensity_john, out$density, na.rm=TRUE)
    ymax <- max(out$density, maxdensity)
    ## create plot
    if (is.null(main)) main <- paste('Histogram of', xname, sep=" ")
    hist(x, breaks=breaks,
         xlab = xname,
         xlim=c(xmin,xmax+(xmax-xmin)/breaks),
         ylim=c(0,maxdensity),
         freq=FALSE,
         main=main)
    if (subtitle == 'yes') {
        n <- w <- j <- NULL
        if (grepl('n', type)) n <- 'red = normal,'
        if (grepl('w', type)) w <- 'blue = Weibull,'
        if (grepl('j', type)) j <- 'black = Johnson'
        ## subtitle <- list('line color: red = normal, blue = Weibull, black = Johnson',
        ##                  'line type: solid = distribution or mean, dashed = 1-sided upper bound')
        subtitle <- list(paste('line color:', n, w, j, sep=' '),
                         'line type: solid = distribution or mean, dashed = 1-sided upper bound')
        mtext(subtitle, side=3, line=c(0.75, 0), cex=.75, col='black')
    } else if (subtitle == 'no') {
        ## skip subitile
    } else {
        ## use user specified subitile
        mtext(subtitle)
    }

    ## add distributions
    if (grepl('n', type)) lines(x=xrange, y=xdensity_norm, col='red',   lty=1)
    if (grepl('w', type)) lines(x=xrange, y=xdensity_weib, col='blue',  lty=1)
    if (grepl('j', type)) lines(x=xrange, y=xdensity_john, col='black', lty=1)

    ## add lines for mean and upper 1-sided 99/99 tolerance limits
    abline(v=xmean,col="red")
    if (isTRUE(upperbound)) {
        if (grepl('n', type)) abline(v=upper_tolerance_limit_norm,col="red",  lty=2)
        if (grepl('w', type)) abline(v=upper_tolerance_limit_weib,col="blue", lty=2)
        if (grepl('j', type)) abline(v=upper_tolerance_limit_john,col="black",lty=2)
    }

    ## print to screen
    if (suppress == 'no') {
        cat("Upper, 1-Sided Tolerance Limits\n")
        cat("confidence =", 1-alpha, ", coverage proportion", proportion, '\n')
        cat("-------------------------------")
        cat("\n")
        if (grepl('n', type)) {
            cat("Normal distribution (red):\n")
            cat("   mean                =",xmean,"\n")
            cat("   standard deviation  =",xsd,"\n")
            cat("   tolerance limit     =",upper_tolerance_limit_norm,"\n")
            cat("\n")
        }
        if (grepl('w', type)) {
            cat("Weibull distribution (blue):\n")
            cat("   shape               =",shape,"\n")
            cat("   scale               =",scale,"\n")
            cat("   tolerance limit     =",upper_tolerance_limit_weib,"\n")
            cat("\n")
        }
        if (grepl('j', type)) {
            cat("Johnson distribution (black):\n")
            cat("   gamma               =",jparms$gamma ,"\n")
            cat("   delta               =",jparms$delta ,"\n")
            cat("   xi                  =",jparms$xi    ,"\n")
            cat("   lambda              =",jparms$lambda,"\n")
            cat("   type                =",jparms$type  ,"\n")
            cat("   tolerance limit     =",upper_tolerance_limit_john,"\n")
            cat("   (tolerance limit is the distribution bound if type SB or SL)\n")
        }
    }

    return(list(sided = '1-sided, upper limits',
                proportion = proportion,
                alpha = alpha,
                nparms = list(mean = xmean, sd=xsd),
                wparms = list(shape = shape, scale = scale),
                jparms = jparms,
                tol_out_norm=tol_out_norm,
                tol_out_weib=tol_out_weib,
                tol_out_john=tol_out_john))

}

## set.seed(1)
## jparms <- list(gamma = -1.039, delta = 1.66, xi = 14.46, lambda = 6.95, type    = 'SU')
## xjohn <- SuppDists::rJohnson(999, parms=jparms) + 2
## out   <- hist_nwj(xjohn, jfit=jparms)

## out <- hist_nwj(mtcars$mpg)
## out <- hist_nwj(mtcars$mpg, type='n')
## out <- hist_nwj(mtcars$mpg, type='w')
## out <- hist_nwj(mtcars$mpg, type='j')
## out <- hist_nwj(mtcars$mpg, type='nw')


correlations <- function(x, y, block=5, nboot=1000) {

	orig <- cor(x,y)
	distr <- array(0, nboot)

	for(boot in 1:nboot) {

		nblock <- length(x)/block

		tmpx <- sample(seq(1:(length(x)-block)), size=nblock, replace=TRUE)
		tmpy <- sample(seq(1:(length(y)-block)), size=nblock, replace=TRUE)

		x.b <- 0
		y.b <- 0

		for(i in 1:nblock) {
			x.b <- c(x.b, x[tmpx[i]:(tmpx[i]+block-1)])
			y.b <- c(y.b, y[tmpy[i]:(tmpy[i]+block-1)])
		}
		distr[boot] <- cor(x.b, y.b)
	}

	p <- length(which(abs(distr) >= abs(orig)))/nboot

    my_return <- list('p' = p, 'distr' = distr)

	return (my_return)
}

data <- read.csv("C:/Users/LucasMarquesGasparin/Desktop/Learning/TCC/Data/Processed/1.csv")

rr1  <- correlations(data$RR_A,data$RR_B)
pos1 <- correlations(data$Pos_A,data$Pos_B)
del1 <- correlations(data$Delta_PosA, data$Delta_PosB)

rp1 <-correlations(data$RR_A,data$Pos_A)
rd1 <-correlations(data$RR_A,data$Delta_PosA)
rp1_ <-correlations(data$RR_B,data$Pos_B)
rd1_ <-correlations(data$RR_B,data$Delta_PosB)
crp1 <-correlations(data$RR_A,data$Pos_B)
crd1 <-correlations(data$RR_A,data$Delta_PosB)
crp1_ <-correlations(data$RR_B,data$Pos_A)
crd1_ <-correlations(data$RR_B,data$Delta_PosA)

crd1$p
crd2$p
crd3$p
crd4$p
crd5$p
crd6$p

data <- read.csv("C:/Users/LucasMarquesGasparin/Desktop/Learning/TCC/Data/Processed/2.csv")

rr2  <- correlations(data$RR_A,data$RR_B)
pos2 <- correlations(data$Pos_A,data$Pos_B)
del2 <- correlations(data$Delta_PosA, data$Delta_PosB)

rp2 <-correlations(data$RR_A,data$Pos_A)
rd2 <-correlations(data$RR_A,data$Delta_PosA)
rp2_ <-correlations(data$RR_B,data$Pos_B)
rd2_ <-correlations(data$RR_B,data$Delta_PosB)

crp2 <-correlations(data$RR_A,data$Pos_B)
crd2 <-correlations(data$RR_A,data$Delta_PosB)
crp2_ <-correlations(data$RR_B,data$Pos_A)
crd2_ <-correlations(data$RR_B,data$Delta_PosA)

data <- read.csv("C:/Users/LucasMarquesGasparin/Desktop/Learning/TCC/Data/Processed/3.csv")

rr3  <- correlations(data$RR_C,data$RR_D)
pos3 <- correlations(data$Pos_C,data$Pos_D)
del3 <- correlations(data$Delta_PosC, data$Delta_PosD)

rp3 <-correlations(data$RR_C,data$Pos_C)
rd3 <-correlations(data$RR_C,data$Delta_PosC)
rp3_ <-correlations(data$RR_D,data$Pos_D)
rd3_ <-correlations(data$RR_D,data$Delta_PosD)
crp3 <-correlations(data$RR_C,data$Pos_D)
crd3 <-correlations(data$RR_C,data$Delta_PosD)
crp3_ <-correlations(data$RR_D,data$Pos_C)
crd3_ <-correlations(data$RR_D,data$Delta_PosC)

data <- read.csv("C:/Users/LucasMarquesGasparin/Desktop/Learning/TCC/Data/Processed/4.csv")

rr4  <- correlations(data$RR_C,data$RR_D)
pos4 <- correlations(data$Pos_C,data$Pos_D)
del4 <- correlations(data$Delta_PosC, data$Delta_PosD)

rp4 <-correlations(data$RR_C,data$Pos_C)
rd4 <-correlations(data$RR_C,data$Delta_PosC)
rp4_ <-correlations(data$RR_D,data$Pos_D)
rd4_ <-correlations(data$RR_D,data$Delta_PosD)

crp4 <-correlations(data$RR_C,data$Pos_D)
crd4 <-correlations(data$RR_C,data$Delta_PosD)
crp4_ <-correlations(data$RR_D,data$Pos_C)
crd4_ <-correlations(data$RR_D,data$Delta_PosC)

data <- read.csv("C:/Users/LucasMarquesGasparin/Desktop/Learning/TCC/Data/Processed/5.csv")

rr5  <- correlations(data$RR_E,data$RR_F)
pos5 <- correlations(data$Pos_E,data$Pos_F)
del5 <- correlations(data$Delta_PosE, data$Delta_PosF)

rp5 <-correlations(data$RR_E,data$Pos_E)
rd5 <-correlations(data$RR_E,data$Delta_PosE)
rp5_ <-correlations(data$RR_F,data$Pos_F)
rd5_ <-correlations(data$RR_F,data$Delta_PosF)

crp5 <-correlations(data$RR_E,data$Pos_F)
crd5 <-correlations(data$RR_E,data$Delta_PosF)
crp5_ <-correlations(data$RR_F,data$Pos_E)
crd5_ <-correlations(data$RR_F,data$Delta_PosE)

data <- read.csv("C:/Users/LucasMarquesGasparin/Desktop/Learning/TCC/Data/Processed/6.csv")

rr6  <- correlations(data$RR_E,data$RR_F)
pos6 <- correlations(data$Pos_E,data$Pos_F)
del6 <- correlations(data$Delta_PosE, data$Delta_PosF)

rp6 <-correlations(data$RR_E,data$Pos_E)
rd6 <-correlations(data$RR_E,data$Delta_PosE)
rp6_ <-correlations(data$RR_F,data$Pos_F)
rd6_ <-correlations(data$RR_F,data$Delta_PosF)

crp6 <-correlations(data$RR_E,data$Pos_F)
crd6 <-correlations(data$RR_E,data$Delta_PosF)
crp6_ <-correlations(data$RR_F,data$Pos_E)
crd6_ <-correlations(data$RR_F,data$Delta_PosE)

rr1$p
hist(rr1$distr)

pos1$p
hist(pos1$distr)

del1$p
hist(del1$distr)

# Simulação

X <- vector(length = T)
Y <- vector(length = T)
T = 1000
nboot = 1000
p_valores = array(0, nboot)
for(boot in 1:nboot) {
	t = 1
	X[0] <- rnorm(0)
	Y[0] <- rnorm(0)
	while (t < T) {
		t = t + 1
		Y[t] <- 0.5*Y[t-1] + rnorm(1)
		X[t] <- 0.5*X[t-1] + rnorm(1)
	}
	rr <- correlations(X, Y)
	p_valores[boot] <- rr$p
}

hist(p_valores)


# Scrips para realizar graficos en R

library(ggplot2)
library(dplyr)

data <- read.csv("data/pkm.csv")
colnames(data)
# violin
p <- ggplot(data, aes(x = status, y = defense,  fill = status )) +
     geom_violin() + theme_minimal()
p

# desnsidad
q <- ggplot(data, aes(x = hp, group = status, fill = status)) +
     geom_density(alpha = 0.4) + theme_minimal()
q

# scatter

pkm <- data %>% filter(status==c("Normal","Legendary"), generation == 1)
pq <- ggplot(pkm, aes(x = hp, y = defense, color = status)) +
      geom_point(size = 4, alpha = 0.5) + theme_minimal()
pq

table(data$status)
colnames(data)
table(data$type_1)

Burbujas
n <- 100
a <- rnorm(n, 30, 2)
b <- rbinom(n, 200, 1/3)
s <- c(5, 10, 20, 30)
ss <- sample(s, n, replace = TRUE)

temp <- data.frame(columna_1 = a, columna_2 = b, columna_3 = ss)
View(temp)

ggplot(temp, aes(x = columna_1, y = columna_2, size = columna_3)) +
     geom_point(alpha = 0.7) +  theme_minimal()

# Ejemplo 2. Burbuja
tmp <- data %>% filter(type_1 == "Ghost")

fantasma <- tmp %>% ggplot(aes(x = hp, y = defense,
          size = attack, color = speed )) +
          geom_point(alpha = 0.7) + theme_minimal()
fantasma


lengthexpression_RPM_distribution_of_identified_small_RNA_loci<- function(fprefix='input',wdir=".") {

start_time <- proc.time()
cat("Distribution of RPM values per sncRNA class (M3.05) started", date(), "\n")

# Plots for Module 3 Analysis and visualization of SPAR output
# Session: Expression characteristics

# Module_3_Figure_5(Figure 3.05)
# Description: Distribution of log 10 RPM values of all loci per sncRNA class
# input: input_annot.with_conservation.xls, input.unannot.final.with_conservation.xls
# output: RPM_distribution_of_identified_small_RNA_loci.png / RPM_distribution_of_identified_small_RNA_loci.pdf

# parameters for the plot
datafile1=paste(wdir, "/", fprefix, "_annot.with_conservation.xls", sep="")
datafile2=paste(wdir, "/", fprefix, "_unannot.with_conservation.xls", sep="")
BASENAME = "RPM_distribution_of_identified_small_RNA_loci"
PLOTTITLE="RPM distribution of all loci \nacross all RNA class"
XTITLE="Log10(RPM)"
YTITLE="Density"

# libraries needed
suppressPackageStartupMessages(library(ggplot2))
suppressPackageStartupMessages(library(RColorBrewer))

#args<-commandArgs(TRUE)
#datafile1=args[1] # input file 1
#datafile2=args[2] # input file 2
#wdir=args[3] # output / working directory
#if (length(args)<1) { stop("ERROR: No input! USAGE: script inputfile <output-dir>")}
#if (length(args)<2) { stop("ERROR: No input! USAGE: script inputfile <output-dir>")}
#if (length(args)<3) { wdir="." }
#use current dir if no
#working dir has been specified

# output image file
pngfile = paste(wdir, "/../figures/", paste(BASENAME,".png",sep=""), sep="")
#pdffile= paste(wdir, "/", paste(BASENAME,".pdf",sep=""), sep="")

# Read in data
D = read.table(datafile1,sep='\t',header=T,comment.ch="")
E = read.table(datafile2,sep='\t',header=T,comment.ch="")
E$annotRNAclass = "unannot"
#DE = rbind(D[,c(1:20,25,29:31)],E)
DE = rbind(D,E)
DE$annotRNAclass2 = DE$annotRNAclass
levels(DE$annotRNAclass2)[1:4]<-"miRNA"
levels(DE$annotRNAclass2)[5:6]<-"snoRNA"

## making necessary quantiles
u = log10(DE$peakRPM)
quantiles1 = quantile(u, probs=seq(0,1,.1)); quantiles1 = quantiles1[c(2,10)]
quantiles2 = quantile(u, probs=seq(0,1,.25)); quantiles2 = quantiles2[c(2:4)]
quantile_line = c(quantiles1, quantiles2)[c(2,4,5)]; quantile_line = sort(quantile_line); quantile_line = data.frame(t(quantile_line))

p = ggplot(DE, aes(x=log10(DE$peakRPM))) + geom_density(aes(group=DE$annotRNAclass2))
py_plot = max(ggplot_build(p)$data[[1]]$y)

## change yaxis axis + title names
## p$labels$colour="Categories"

#scale_fill_manual(values = getPalette(colourCount))
#scale_fill_manual

#ggplot(D, aes(log10(peakRPM), ..count.., fill = annotRNAclass2))+
#geom_density(position = "fill")+
#scale_fill_brewer(palette="Set2")+
#geom_vline(data = quantile_line,aes(xintercept = quantile_line$X10.),color="black",linetype = "dashed",size=1.25)+
#geom_vline(data = quantile_line,aes(xintercept = quantile_line$X90.),color="black",linetype = "dashed",size=1.25)

# make plot
int = sort.int(ggplot_build(p)$data[[1]]$x, index.return=TRUE)
front <- data.frame(position = quantile_line)

front = rbind(quantile_line,rep(py_plot*0.75,5))
front = t(front)
colnames(front)=c("x","y")
front = data.frame(front)

#rownames(front)[1] = paste("10%, log10(RPM)=",round(quantile_line$X10,2))
#rownames(front)[2] = paste("25%, log10(RPM)=",round(quantile_line$X25,2))
#rownames(front)[3] = paste("50%, log10(RPM)=",round(quantile_line$X50,2))
#rownames(front)[4] = paste("75%, log10(RPM)=",round(quantile_line$X75,2))
#rownames(front)[5] = paste("90%, log10(RPM)=",round(quantile_line$X90,2))

rownames(front)[1] = paste("50%, log10(RPM)=",round(quantile_line$X50,2))
rownames(front)[2] = paste("75%, log10(RPM)=",round(quantile_line$X75,2))
rownames(front)[3] = paste("90%, log10(RPM)=",round(quantile_line$X90,2))

png(pngfile,width = 7, height = 7, units = 'in', res = 300, type="cairo")
print(ggplot(DE, aes(x=log10(DE$peakRPM),colour=as.factor(DE$annotRNAclass2))) +
		geom_density(aes(group=DE$annotRNAclass2),size=1.5)+
		scale_color_brewer(palette = "Spectral",name = "sncRNA classes")+
		coord_cartesian(ylim=c(0,py_plot+0.5))+ theme_classic()+
		ggtitle(PLOTTITLE) + xlab(XTITLE)+ylab(YTITLE)+
		geom_vline(xintercept = as.numeric(quantile_line),color="black",linetype = "dashed",size=1.25)+
		geom_text(data=front,aes(x=x-0.1,y=y+0.5,label=rownames(front)), colour="blue", angle=90,size=4)+
		theme(legend.position="bottom")
		)
dev.off()

cat("Total time for RPM per sncRNA class (M3.05) analysis:", (proc.time() - start_time)[['elapsed']], "seconds (", date(), ")\n")
}
# RPM_distribution_of_identified_small_RNA_loci(fprefix=fprefix,wdir=wdir)


#brupoon 2015, MIT license
#install.packages("doBy")
#install.packages("ggplot2")
library(doBy)
library(ggplot2)
library(gdata)
library(plyr)
#data
dat <- read.xls("~/dev/dsci/rollingsales/rollingsales_manhattan.xls", pattern="BOROUGH")
dat$SALE.PRICE.N <- as.numeric(gsub("[^[:digit:]]","",dat$SALE.PRICE)) #clean using regex
sale.price.count <- count(is.na(dat$SALE.PRICE.N))
names(dat) <- tolower(names(dat)) #lowercase all names in the data

#clean again using regex
dat$gross.sqft <- as.numeric(gsub("[^[:digit:]]","",dat$gross.square.feet))
dat$land.sqft <- as.numeric(gsub("[^[:digit:]]","",dat$land.square.feet))

dat$sale.date <- as.Date(dat$sale.date)
dat$year.built <- as.numeric(as.character(dat$year.built))

#use attach to make things easier
attach(dat)
#we want to make sure our sale data isn't messed up in some weird way
hist(sale.price.n)
hist(sale.price.n[sale.price.n>0])
hist(gross.sqft[sale.price.n==0])
detach(dat)

#remove non-sales
dat.sale <- dat[dat$sale.price.n!=0,]

plot.sqft.price <- plot(dat.sale$gross.sqft,dat.sale$sale.price.n)
plot.sqft.price.log <- plot(log(dat.sale$gross.sqft),log(dat.sale$sale.price.n))

#what if we want to look at 1- 2- and 3- family homes?
dat.homes <- dat.sale[which(grepl("FAMILY",dat.sale$building.class.category)),]
plot.sqft.price.fam <- plot(log(dat.homes$gross.sqft,log(dat.homes$sale.price.n)))

dat.homes[which(dat.homes$sale.price.n<100000),]
	[order(dat.homes[which(dat.homes$sale.price.n<100000),]
	$sale.price.n),]

#remove outliers that weren't sales

dat.homes$outliers <- (log(dat.homes$sale.price.n) <=5) + 0
dat.homes <- dat.homes[which(dat.homes$outliers==0),] #adjust dat.homes to not include these

plot.sqft.price.fam.clean <- plot(log(dat.homes$gross.sqft),log(dat.homes$sale.price.n))

#now we can actually do some linear regression
model.a <- lm(log(dat.homes$sale.price.n) ~ log(dat.homes$gross.sqft))


#''' Adding columns to dataframes
#'
#' Two ways to do it:
#' 1) Base-R
#' 2) dplyr package
# '''

#Load  packages

library(dplyr)
library(caret)
library(tidyverse)

#''' =========================================================
#'Dataset is from the midwest dataset from the ggplot2 package
#'=============================================================

# to load the data into the workspace
data("midwest")

#'''=====================================================
#' RENAMING A DATASET
#'   - since only exploring a small part of this dataset
#'=======================================================
midwestCollegeEdu <- midwest

# inspect the data
head(midwestCollegeEdu) # will show first few rows and all the variable names (baseR)
midwestCollegeEdu %>% glimpse() # from tibble package - part of tidyverse package

#'''================================================================
#'Adding a new variable with mutate()
#'   - allows for calculation of new values to the variables created
#'====================================================================

midwestCollegeEdu <- mutate(midwestCollegeEdu, numCollegeEdu = (round(poptotal * percollege))) # rounded

# created an additional column erroneously and so deleted it
midwestCollegeEdu <- mutate(midwestCollegeEdu, numCollegeEdu = NULL)

# FOR LARGE DATASETS, TO PREVENT OUT OF MEMORY ERRORS use
library(data.table)
midwestCollegeEdu <- data.table(midwestCollegeEdu) #have to create it as a data.table though
midwestCollegeEdu[, numCollegeEdu:=NULL] #":= is an assignment by reference, and can be used with other assignment operators"


myDataFile <- read.csv('/Users/saugat/Downloads/2008.csv')

table(myDataFile$Origin == 'LAX')

# Top 200 airports with low number of flights
top200airports <- names(sort(table(myDataFile$Origin))[1:200])
sum(myDataFile$Origin %in% top200airports)
table(myDataFile$Dest)[top20airports]

table(myDataFile$Dest)['DCA']
table(myDataFile$Dest)[c('DCA', 'IAD')]

top20airports <- names(sort(table(myDataFile$Origin), decreasing = TRUE)[1:20])
sum(myDataFile$Origin %in% top20airports)

tapply(myDataFile$DepDelay <= 0 & myDataFile$Origin == 'IND', myDataFile$Origin, sum, na.rm = TRUE)['IND']
table(myDataFile$Origin)['IND']

tapply(myDataFile$DepDelay <= 0 & myDataFile$Origin == 'IND', myDataFile$Origin, sum, na.rm = TRUE)['IND'] / table(myDataFile$Origin)['IND']

sum(tapply(myDataFile$Origin, list(myDataFile$Origin, myDataFile$Month), length)[c('ATL', 'AUS', 'BDL'), 7:10])

tapply(myDataFile$Origin, list(myDataFile$Origin, myDataFile$Month), length)['IND', ]

class(tapply(myDataFile$Origin, list(myDataFile$Origin, myDataFile$Month), length)[c('IND', 'ATL'), ])

dim(tapply(myDataFile$Origin, list(myDataFile$Origin, myDataFile$Month), length)[c('IND', 'ATL'), ])

longDelays <- subset(myDataFile, myDataFile$DepDelay > 30)

sum(tapply(longDelays$Origin, longDelays$Origin, length)[c('IND', 'ORD')])
tapply(longDelays$Origin, longDelays$Month, length)

v <- ceiling(myDataFile$DepTime/600)

partsofday <- rep(NA, times=dim(myDataFile)[1])

partsofday[v == 1] <- 'early morning'
partsofday[v == 2] <- 'late morning'
partsofday[v == 3] <- 'early evening'
partsofday[v == 4] <- 'late evening'

table(partsofday)

myDataFile$timeofday <- partsofday

dim(myDataFile)

table(myDataFile$Origin == 'IND' & myDataFile$timeofday == 'early morning')


splt=function(x,split,num) {

  x<-as.character(x)
  p1=strsplit(x,split=split,fixed=T)
  p2=unlist(lapply(p1,"[",num))
  return(p2)
}

draws=function(n.iter,n.burnin,n.thin,n.chains=3) {
  return(((n.iter-n.burnin)/n.thin)*n.chains)
}

makeTransparent<-function(someColor, alpha=100)
{
  newColor<-someColor + alpha #I wish
  return(newColor)
}

rmse=function(m,x)
{
  sqrt(mean((x-m)^2))
}

mae=function(m,x)
{
  mean(abs(((x-m))))
}

cloglog=function (theta, bvalue = NULL, inverse = FALSE, deriv = 0, short = TRUE,
          tag = FALSE)
{
  if (is.character(theta)) {
    string <- if (short)
      paste("cloglog(", theta, ")", sep = "")
    else paste("log(-log(1-", theta, "))", sep = "")
    if (tag)
      string <- paste("Complementary log-log:", string)
    return(string)
  }
  if (!inverse && length(bvalue)) {
    theta[theta <= 0] <- bvalue
    theta[theta >= 1] <- 1 - bvalue
  }
  if (inverse) {
    if (deriv > 0) {
      1/Recall(theta = theta, bvalue = bvalue, inverse = FALSE,
               deriv = deriv)
    }
    else {
      junk <- exp(theta)
      -expm1(-junk)
    }
  }
  else {
    switch(deriv + 1, {
      log(-log1p(-theta))
    }, -(1 - theta) * log1p(-theta), {
      junk <- log1p(-theta)
      -(1 - theta) * (1 + junk) * junk
    }, stop("argument 'deriv' unmatched"))
  }
}

binplot<-
function (size,surv, ncuts = 70,...,addy="NO",lcol="darkgreen")
{
    os <- order(size)
    os.surv <- (surv)[os]
    os.size <- (size)[os]
    psz <- tapply(os.size, as.numeric(cut(os.size, ncuts)), mean,
        na.rm = TRUE)
    ps <- tapply(os.surv, as.numeric(cut(os.size, ncuts)), mean,
        na.rm = TRUE)

    if(addy=="NO") {
        plot(as.numeric(psz), as.numeric(ps),...) }

    else{ points(as.numeric(psz), as.numeric(ps),...) }
        lines(as.numeric(psz), as.numeric(ps),...,col=lcol,lwd=2)
        return(cbind(as.numeric(psz),as.numeric(ps)))}

#convert between population and individual data
expand.dft <- function(x, na.strings = "NA", as.is = FALSE, dec = ".") {
    # Take each row in the source data frame table and replicate it
    # using the Freq value
    DF <- sapply(1:nrow(x),
                 function(i) x[rep(i, each = x$Freq[i]), ],
                 simplify = FALSE)

    # Take the above list and rbind it to create a single DF
    # Also subset the result to eliminate the Freq column
    DF <- subset(do.call("rbind", DF), select = -Freq)

    # Now apply type.convert to the character coerced factor columns
    # to facilitate data type selection for each column
    for (i in 1:ncol(DF)) {
        DF[[i]] <- type.convert(as.character(DF[[i]]),
                                na.strings = na.strings,
                                as.is = as.is, dec = dec)
    }

    DF
}

#NOTE THAT FOR GLMS YOU CAN USE PREDICT INSTEAD OF X
  lz<-function(x) {log(x+1)}

  RSS1<-function(m,x) {sum((lz((m))-lz(x))^2)}
  TSS1<-function(x) {sum((lz(x)-lz(mean(x)))^2)}

  RSS<-function(m,x) {sum((((m))-(x))^2)}
  TSS<-function(x) {sum(((x)-(mean(x)))^2)}

  R2<-function(m,x,logo=F) {
    mors<-na.omit(data.frame(m,x))
    m<-mors$m
    x<-mors$x

    if(logo==F) {return(1-RSS(m,x)/TSS(x))} else {return(1-RSS1(m,x)/TSS1(x))}
  }

#summary[[2]]
gisum<-function(model,Start=1,Finish=20) {return(model[[2]]$summary[Start:Finish,])}

gipar<-function(model) {return(model[2]$BUGSoutput$sims.list)}

Rhat<-function(model) {
return(model[[2]]$summary[,8])
}

Q<-function(model,variable,colo="light gray") {
simlist<-gipar(model)

simvar<-which(names(simlist)==variable)

plot(density(simlist[[simvar]]),main=variable)
polygon(density(simlist[[simvar]]),col=colo)

abline(v=quantile(simlist[[simvar]],c(0.025,0.5,0.975)),lwd=2)

return(quantile(simlist[[simvar]],c(0.025,0.5,0.975)))}

pplotCOEF<-function(sims,thickness=2,lab1="",lab2="Values",listorno="T",...,cexX=1.1) {      #this is designed to plot the 95% confidence intervals
if(listorno=="T") {simlist<-sims

simlist$deviance<-NULL

} else{
simlist<-gipar(sims)
dumb<-which(names(simlist)=="deviance")

simlist<-simlist[-dumb]
}
variablenames<-names(simlist)
xo<-c(1:length(names(simlist)))

upo<-max(unlist(lapply(simlist,ups)))
downo<-min(unlist(lapply(simlist,lows)))

plot(0,xo[1],pch="",ylim=c(downo,upo),xlim=c(1,max(xo)),xlab=lab1,ylab=lab2,xaxt="n",...)
 axis(side=1,at=c(1:max(xo)),labels=variablenames,cex.axis=cexX,las=2)
grid()
 abline(h=0,lty=2,col="gray",lwd=thickness)
for(i in 1:length(xo)) {
valz<-simlist[[i]]
m<-median(valz)
u<-ups(valz)
l<-lows(valz)

u5<-ups5(valz)
l5<-lows5(valz)

segments(x0=xo[i],y0=l5,y1=u5,lty=1,col="gray",lwd=10)
points(m~xo[i],pch=19,col="black",cex=1.5)
segments(x0=xo[i],y0=l,y1=u,lty=1,col="black",lwd=3)

}
}

pplot2<-function(input,pvalz,lab1="Predictor",cexo=0.5,lab2="Response",ylimo=c(min(l),max(u)),
xlimo=c(min(input),max(input)),maino="",meormed="med") {      #this is designed to plot the 95% confidence intervals

if(meormed=="me") {
m<-apply(pvalz,2,mean)
}
else{m<-apply(pvalz,2,median)}

u<-apply(pvalz,2,ups)
l<-apply(pvalz,2,lows)
have<-data.frame(l,m,u,input)
colnames(have)<-c("lower","mean","upper","input")
have<-have[order(have$input),]
m<-have$m
l<-have$l
u<-have$u
ip<-have$input

plot(m~ip,ylim=ylimo,xlim=xlimo,pch=19,cex=cexo,xlab=lab1,ylab=lab2,col="black",main=maino,cex.lab=1.8,cex.axis=1.8)
#lines(m~ip,lty=2)
for(i in 1:length(m)) {
segments(x0=ip[i],y0=l[i],y1=u[i],lty=2,col="gray")
#points(m~ip,pch=19,cex=cexo,col="black")
}
}

ups<-function(listie) {
want<-length(listie)*0.975
take<-sort(listie)[want]
return(take)
}

ups5<-function(listie) {
  want<-length(listie)*0.75
  take<-sort(listie)[want]
  return(take)
}

lows5<-function(listie) {
  want<-length(listie)*0.25
  take<-sort(listie)[want]
  return(take)
}

lows<-function(listie) {
want<-length(listie)*0.025
take<-sort(listie)[want]
return(take)
}

ppointFX<-function(input,predicted) { #this is designed for plotting the 95% confidence intervals around a functional relationship
pvalz<-predicted
m<-apply(pvalz,2,median)
u<-apply(pvalz,2,ups)
l<-apply(pvalz,2,lows)
have<-data.frame(l,m,u,input)
colnames(have)<-c("lower","mean","upper","input")
have<-have[order(have$input),]
m<-have$m
l<-have$l
u<-have$u
ip<-have$input
points(m~ip,ylim=c(min(l),max(u)),pch=19,col="gray")
lines(m~ip,lty=2)
#points(u~ip,pch=19,col="gray") points is to confusing
lines(u~ip,lty=2,col="red") #the lines might be good if
#points(l~ip,pch=19,col="gray")
lines(l~ip,lty=2,col="red")
return(have)
}

pplotFX<-function(input,predicted,lab1,lab2) { #this is designed for plotting the 95% confidence intervals around a functional relationship
pvalz<-predicted
m<-apply(pvalz,2,median)
u<-apply(pvalz,2,ups)
l<-apply(pvalz,2,lows)
have<-data.frame(l,m,u,input)
colnames(have)<-c("lower","mean","upper","input")
have<-have[order(have$input),]
m<-have$m
l<-have$l
u<-have$u
ip<-have$input
plot(m~ip,ylim=c(min(l),max(u)),pch=19,col="gray",xlab=lab1,ylab=lab2)
lines(m~ip,lty=2)
#points(u~ip,pch=19,col="gray") points is to confusing
lines(u~ip,lty=2,col="red") #the lines might be good if
#points(l~ip,pch=19,col="gray")
lines(l~ip,lty=2,col="red")
return(have)
}

pplot<-function(input,predicted,lab1,lab2) {      #this is designed to plot the 95% confidence intervals
pvalz<-predicted
m<-apply(pvalz,2,median)
u<-apply(pvalz,2,ups)
l<-apply(pvalz,2,lows)
have<-data.frame(l,m,u,input)
colnames(have)<-c("lower","mean","upper","input")
have<-have[order(have$input),]
m<-have$m
l<-have$l
u<-have$u
ip<-have$input
plot(m~ip,ylim=c(min(l),max(u)),pch=19,col="gray",xlab=lab1,ylab=lab2)
#lines(m~ip,lty=2)
for(i in 1:length(m)) {
segments(x0=ip[i],y0=l[i],y1=u[i],lty=2,col="gray70")
}
#points(u~ip,pch=19,col="gray") points is to confusing
#lines(u~ip,lty=2,col="red") #the lines might be good if
#points(l~ip,pch=19,col="gray")
#lines(l~ip,lty=2,col="red")
return(have)
}

ppoint<-function(input,predicted,lab1,lab2) {      #this is designed to plot the 95% confidence intervals
pvalz<-predicted
m<-apply(pvalz,2,median)
u<-apply(pvalz,2,ups)
l<-apply(pvalz,2,lows)
have<-data.frame(l,m,u,input)
colnames(have)<-c("lower","mean","upper","input")
have<-have[order(have$input),]
m<-have$m
l<-have$l
u<-have$u
ip<-have$input
points(m~ip,ylim=c(min(l),max(u)),pch=19,col="gray")
#lines(m~ip,lty=2)
for(i in 1:length(m)) {
segments(x0=ip[i],y0=l[i],y1=u[i],lty=2,col="gray70")
}
#points(u~ip,pch=19,col="gray") points is to confusing
#lines(u~ip,lty=2,col="red") #the lines might be good if
#points(l~ip,pch=19,col="gray")
#lines(l~ip,lty=2,col="red")
return(have)
}

#I'm pretty sure this is wrong-o, wrong-o!
binMSPE<-function(y,sims.p) {
p<-apply(sims.p,2,mean)
mspe<-sum((p-y)^2)+sum(p*(1-p))
m<-sum((p-y)^2)
great<-data.frame(mspe,m)
names(great)<-c("MSPE","mean only")
return(great)
}

#I'm pretty sure this is wrong-o, wrong-o!
binMSPE<-function(y,n=1,sims.p) {
  p<-apply(sims.p,2,mean)
  mspe<-sum((n*p-n*y)^2)+sum((n*p)*(1-p))
  m<-sum((p-y)^2)
  great<-data.frame(mspe,m)
  names(great)<-c("MSPE","mean only")
  return(great)
}

#(2/(length(y)*(length(y)+1))) #an alternative. I'm not sure which of these to use

poisMSPE<-function(y,sims.p,its=length(sims.p[1,])) {

runny<-rep(0,times=its)
for(i in 1:its) {

runny[i]<-(1/(length(y)))*sum((log(sims.p[,i]+0.5)-log(y+0.5))^2)
}
return(runny)
}

poisMSPE1it<-function(y,sims.p) {

runny<-(1/(length(y)))*sum((log(sims.p+0.5)-log(y+0.5))^2)

return(runny)
}

normalMSPE<-function(y,sims.p) {
p<-apply(sims.p,2,mean)
v<-apply(sims.p,2,var)
mspe<-sum((p-y)^2)+sum(v)
m<-sum((p)^2)
great<-data.frame(mspe,m)
names(great)<-c("MSPE","mean only")
return(great)
}

#OR IF SIGMA IS VARIABLE:

normalMSPEvar<-function(y,sims.p,sigma) {
p<-apply(sims.p,2,mean)
sigma.m<-apply(sigma,2,mean)
mspe<-sum((p-y)^2)+sum(sigma.m)
m<-sum((p)^2)
great<-data.frame(mspe,m)
names(great)<-c("MSPE","mean only")
return(great)
}

#what's next:
#1. experiment with value for total seeds
#2. put in covariates for final model! yay!
#3.. dealing with missing values

###NOTES:
#the lmer model for site with a binomial model is 0 for all random effects...seems problematic

credint<-function(x) {
gret<-sort(x)
up<-round(length(x)*0.95)
down<-round(length(x)*0.05)
final<-c(gret[down],median(gret),mean(gret),gret[up])
names(final)<-c("lower 5%","median","mean","upper 95%")
return(final)
}

stdize<-function(x) {(x-mean(x))/(2*sd(x))}

transdis<-function(x,y) {sqrt((521995-x)^2+(1727781-y)^2)
}

facTOlevs<-function(fac) {
levs<-levels(fac)
mats<-matrix(NA,nrow=length(fac),ncol=length(levs))
for(i in 1:length(levs)) {
mats[,i]<-ifelse(fac==levs[i],1,0)
}
colnames(mats)<-levs
return(data.frame(mats))
}

recodeFACTOR<-function(FACTOR) {
number<-as.numeric(as.factor(as.numeric(FACTOR)))
should<-c(1:max(number))
if(length(which(should %in% number==F))>0) {
return("BROKE BROKE BROKE")
}
else {return(number)}
}

Rhatty<-function(listo) {
  rhat<-Rhat(listo)
  hist(rhat,breaks=100)
  print(max(rhat))
  return(listo[[2]]$summary[which(listo[[2]]$summary[,8]>1.1),])
}


context("Breaks - log")

test_that("Five ticks over 10^4 range work", {
  expect_equal(log_breaks()(10^(1:5)), 10 ^ (1:5))

})