library(shiny)
library(ggplot2)
library(Cairo);options(shiny.usecairo=TRUE)

options(warn=-1)

server <- function(session, input, output) {

  standardStorageTier1 <- 0.023
  standardStorageTier2 <- 0.022
  standardStorageTier3 <- 0.021
  standardPUT <- 0.005 / 1000
  standardGET <- 0.0004 / 1000

  infrequentStorage <- 0.0125
  infrequentPUT <- 0.01 / 1000
  infrequentGET <- 0.001 / 1000
  infrequentRetrieval <- 0.01

  oneZoneStorage <- 0.01
  oneZonePUT <- 0.01 / 1000
  oneZoneGET <- 0.001 / 1000
  oneZoneRetrieval <- 0.01

  glacierstorage <- 0.004
  glacierPUT <- 0.05 / 1000
  glacierRetrievalExpedited <- 0.03
  glacierRetrievalStandard <- 0.01
  glacierRetrievalBulk <- 0.0025
  glacierRetrievalExpeditedReq <- 10 / 1000
  glacierRetrievalStandardReq <- 0.05 / 1000
  glacierRetrievalBulkReq <- 0.025 / 1000

  deepGlacierStorage <- 0.00099
  deepGlacierPUT <- 0.05 / 1000
  deepGlacierRetrievalStandard <- 0.02
  deepGlacierRetrievalBulk <- 0.0025
  deepGlacierRetrievalStandardReq <- 0.10 / 1000
  deepGlacierRetrievalBulkReq <- 0.025 / 1000

  transferOutTier1 <- 0.09
  transferOutTier2 <- 0.085
  transferOutTier3 <- 0.07
  transferOutTier4 <- 0.05

  calculateGB <- function(storageAmount,storageUnit){
    if(storageUnit == "GB"){
      storageAmount
    }else if(storageUnit == "TB"){
      storageAmount * 1024
    }else if(storageUnit == "PB"){
      storageAmount * 1024 * 1024
    }
  }

  convertBack <- function(storageAmount){
    ifelse(storageAmount >= 1024 & storageAmount < 1048576,paste(round(storageAmount / 1024,2),"TB"),
           ifelse(storageAmount >= 1048576,paste(round(storageAmount / 1024 / 1024,2),"PB"),paste(round(storageAmount,2),"GB")))
  }

  calculateGrowthPerc <- function(storageAmount,percentage,n){
    storageAmount * (1+percentage/100)^(0:(n-1))
  }

  calculateGrowthStatic <- function(storageAmount,growth,n){
    storageAmount + (growth)*(1:n-1)
  }

  calculateStorageTier <- function(storageAmount){
    ifelse(storageAmount <= (50*1024),storageAmount * standardStorageTier1,
           ifelse(storageAmount < (500*1024) & storageAmount > (50*1024),((storageAmount-(50*1024))*standardStorageTier2) + (50*1024*standardStorageTier1),
                  ((storageAmount-(500*1024)) * standardStorageTier3) + (450*1024*standardStorageTier2) + (50*1024*standardStorageTier1)))
  }

  calculateDataTransferTier <- function(transferAmount){
    ifelse(transferAmount <= (10*1024),transferAmount * transferOutTier1,
           ifelse(transferAmount <= (50*1024) & transferAmount > (10*1024),((transferAmount-(10*1024))*transferOutTier2) + (10*1024*transferOutTier1),
                  ifelse(transferAmount <= (150*1024) & transferAmount > (50*1024),((transferAmount-(50*1024))*transferOutTier3) + (40*1024*transferOutTier2) + (10*1024*transferOutTier1),
                         ((transferAmount-(150*1024)) * transferOutTier4) + (100*1024*transferOutTier3) + (40*1024*transferOutTier2) + (10*1024*transferOutTier1))))
  }

  calculateStorageAmount <- function(storageAmount,unitType1,unitType2,growth,n){
    storageGB <- calculateGB(storageAmount,unitType1)
    if(unitType2 == "%"){
      temp1 <- calculateGrowthPerc(storageGB,growth,n)
    }else{
      growthGB <- calculateGB(growth,unitType2)
      temp1 <- calculateGrowthStatic(storageGB,growthGB,n)
    }
    temp1
  }

  calculateStorageCosts <- function(storageAmount,unitType1,unitType2,growth,n){
    storageGB <- calculateGB(storageAmount,unitType1)
    if(unitType2 == "%"){
      temp1 <- calculateGrowthPerc(storageGB,growth,n)
    }else{
      growthGB <- calculateGB(growth,unitType2)
      temp1 <- calculateGrowthStatic(storageGB,growthGB,n)
    }
    temp1
  }

  calculateGrowthObj <- function(storageAmount,growth,n,objPerGB,unitType,pricing){
    growthGB <- calculateGB(growth,unitType)
    if(unitType == "%"){
      objGrowth <- c(storageAmount*objPerGB,diff(storageAmount * (1+growth/100)^(0:(n-1)) * objPerGB))
    }else{
      objGrowth <- c(storageAmount*objPerGB,diff((storageAmount + (growthGB)*(1:n-1)) * objPerGB))
    }
    if(is.na(objGrowth)==F & objGrowth != Inf){
      objGrowth * pricing
    }else{
      (1:n) * 0
    }
  }

  calculateStdDataRetrievalCosts <- function(storageAmount,retrievalAmount,n,unitType1,unitType2,unitType3,objPerGB,growth){
    if(unitType2 == "%"){
      temp1 <- calculateStorageAmount(storageAmount,unitType1,unitType3,growth,n) * (retrievalAmount/100)
      temp2 <- temp1 * objPerGB * standardGET
    }else{
      retrievalGB <- calculateGB(retrievalAmount,unitType2)
      temp1 <- rep(retrievalGB,n)
      temp2 <- rep(retrievalGB*objPerGB,n) * standardGET
    }
    if(is.na(calculateDataTransferTier(temp1) + temp2)==F & calculateDataTransferTier(temp1) + temp2 != Inf){
      calculateDataTransferTier(temp1) + temp2
    }else{
      (1:n) * 0
    }
  }

  calculateDataRetrievalCosts <- function(storageAmount,retrievalAmount,n,unitType1,unitType2,unitType3,objPerGB,growth,pricing1,pricing2,retrievalSpeed,expedited1,standard1,bulk1,expedited2,standard2,bulk2){
    if(unitType2 == "%"){
      if(retrievalSpeed == "Expedited"){
        temp1 <- calculateStorageAmount(storageAmount,unitType1,unitType3,growth,n) * (retrievalAmount/100)
        temp2 <- (temp1 * objPerGB * expedited1) + (temp1 * expedited2)
      }else if(retrievalSpeed == "Standard"){
        temp1 <- calculateStorageAmount(storageAmount,unitType1,unitType3,growth,n) * (retrievalAmount/100)
        temp2 <- (temp1 * objPerGB * standard1) + (temp1 * standard2)
      }else if(retrievalSpeed == "Bulk"){
        temp1 <- calculateStorageAmount(storageAmount,unitType1,unitType3,growth,n) * (retrievalAmount/100)
        temp2 <- (temp1 * objPerGB * bulk1) + (temp1 * bulk2)
      }else{
        temp1 <- calculateStorageAmount(storageAmount,unitType1,unitType3,growth,n) * (retrievalAmount/100)
        temp2 <- (temp1 * objPerGB * pricing1) + (temp1 * pricing2)
      }
    }else{
      retrievalGB <- calculateGB(retrievalAmount,unitType2)
      if(retrievalSpeed == "Expedited"){
        temp1 <- rep(retrievalGB,n)
        temp2 <- (rep(retrievalGB*objPerGB,n) * expedited1) + (temp1 * expedited2)
      }else if(retrievalSpeed == "Standard"){
        temp1 <- rep(retrievalGB,n)
        temp2 <- (rep(retrievalGB*objPerGB,n) * standard1) + (temp1 * standard2)
      }else if(retrievalSpeed == "Bulk"){
        temp1 <- rep(retrievalGB,n)
        temp2 <- (rep(retrievalGB*objPerGB,n) * bulk1) + (temp1 * bulk2)
      }else{
        temp1 <- rep(retrievalGB,n)
        temp2 <- (rep(retrievalGB*objPerGB,n) * pricing1) + (temp1 * pricing2)
      }
    }
    if(is.na(calculateDataTransferTier(temp1) + temp2)==F & calculateDataTransferTier(temp1) + temp2 != Inf){
      calculateDataTransferTier(temp1) + temp2
    }else{
      (1:n) * 0
    }
  }

  headers <- c("Month","Storage Amount","Storage Cost","Upload Cost","Data Retrieval Cost","Monthly Cost","Cumulative Total")

  vals <- reactiveValues()
  observe({
    vals$stdA <- as.numeric(paste(gsub("[^0-9.-]","",input$stdStorage)))
    vals$stdB <- input$stdUnit1
    vals$stdC <- as.numeric(paste(gsub("[^0-9.-]","",input$stdObj)))
    vals$stdD <- as.numeric(paste(gsub("[^0-9.-]","",input$stdRetrieval)))
    vals$stdE <- input$stdUnit2
    vals$stdF <- as.numeric(paste(gsub("[^0-9.-]","",input$stdGrowth)))
    vals$stdG <- input$stdUnit3
    vals$stdH <- input$stdMonths
    vals$stdI <- input$copySelect1
    vals$stdStorageGB <- calculateGB(vals$stdA,vals$stdB)
    vals$stdRetrievalGB <- calculateGB(vals$stdD,vals$stdE)
    vals$stdObjPerGB <- vals$stdC / vals$stdStorageGB
    vals$stdMonths <- c(1:vals$stdH)

    vals$stdStorageAmount <- convertBack(calculateStorageAmount(vals$stdA,vals$stdB,vals$stdG,vals$stdF,vals$stdH))
    vals$stdStorageCost <- calculateStorageTier(calculateStorageCosts(vals$stdA,vals$stdB,vals$stdG,vals$stdF,vals$stdH))
    vals$stdUploadCost <- calculateGrowthObj(vals$stdStorageGB,vals$stdF,vals$stdH,vals$stdObjPerGB,vals$stdG,standardPUT)
    vals$stdDataTransferCost <- calculateStdDataRetrievalCosts(vals$stdA,vals$stdD,vals$stdH,vals$stdB,vals$stdE,vals$stdG,vals$stdObjPerGB,vals$stdF)

    vals$stdMonthlyCost <- vals$stdStorageCost + vals$stdUploadCost + vals$stdDataTransferCost
    vals$stdCumulativeCost <- cumsum(vals$stdMonthlyCost)

    vals$stdDf <- data.frame(vals$stdMonths,vals$stdStorageAmount,vals$stdStorageCost,vals$stdUploadCost,vals$stdDataTransferCost,vals$stdMonthlyCost,vals$stdCumulativeCost)

    vals$IAA <- as.numeric(paste(gsub("[^0-9.-]","",input$IAStorage)))
    vals$IAB <- input$IAUnit1
    vals$IAC <- as.numeric(paste(gsub("[^0-9.-]","",input$IAObj)))
    vals$IAD <- as.numeric(paste(gsub("[^0-9.-]","",input$IARetrieval)))
    vals$IAE <- input$IAUnit2
    vals$IAF <- as.numeric(paste(gsub("[^0-9.-]","",input$IAGrowth)))
    vals$IAG <- input$IAUnit3
    vals$IAH <- input$IAMonths
    vals$IAI <- input$copySelect2
    vals$IAStorageGB <- calculateGB(vals$IAA,vals$IAB)
    vals$IARetrievalGB <- calculateGB(vals$IAD,vals$IAE)
    vals$IAObjPerGB <- vals$IAC / vals$IAStorageGB
    vals$IAMonths <- c(1:vals$IAH)

    vals$IAStorageAmount <- convertBack(calculateStorageAmount(vals$IAA,vals$IAB,vals$IAG,vals$IAF,vals$IAH))
    vals$IAStorageCost <- calculateStorageAmount(vals$IAA,vals$IAB,vals$IAG,vals$IAF,vals$IAH) * infrequentStorage
    vals$IAUploadCost <- calculateGrowthObj(vals$IAStorageGB,vals$IAF,vals$IAH,vals$IAObjPerGB,vals$IAG,infrequentPUT)
    vals$IADataTransferCost <- calculateDataRetrievalCosts(vals$IAA,vals$IAD,vals$IAH,vals$IAB,vals$IAE,vals$IAG,vals$IAObjPerGB,vals$IAF,infrequentGET,infrequentRetrieval,"None",1,1,1,1,1,1)

    vals$IAMonthlyCost <- vals$IAStorageCost + vals$IAUploadCost + vals$IADataTransferCost
    vals$IACumulativeCost <- cumsum(vals$IAMonthlyCost)

    vals$IADf <- data.frame(vals$IAMonths,vals$IAStorageAmount,vals$IAStorageCost,vals$IAUploadCost,vals$IADataTransferCost,vals$IAMonthlyCost,vals$IACumulativeCost)

    vals$OIAA <- as.numeric(paste(gsub("[^0-9.-]","",input$OIAStorage)))
    vals$OIAB <- input$OIAUnit1
    vals$OIAC <- as.numeric(paste(gsub("[^0-9.-]","",input$OIAObj)))
    vals$OIAD <- as.numeric(paste(gsub("[^0-9.-]","",input$OIARetrieval)))
    vals$OIAE <- input$OIAUnit2
    vals$OIAF <- as.numeric(paste(gsub("[^0-9.-]","",input$OIAGrowth)))
    vals$OIAG <- input$OIAUnit3
    vals$OIAH <- input$OIAMonths
    vals$OIAI <- input$copySelect3
    vals$OIAStorageGB <- calculateGB(vals$OIAA,vals$OIAB)
    vals$OIARetrievalGB <- calculateGB(vals$OIAD,vals$OIAE)
    vals$OIAObjPerGB <- vals$OIAC / vals$OIAStorageGB
    vals$OIAMonths <- c(1:vals$OIAH)

    vals$OIAStorageAmount <- convertBack(calculateStorageAmount(vals$OIAA,vals$OIAB,vals$OIAG,vals$OIAF,vals$OIAH))
    vals$OIAStorageCost <- calculateStorageAmount(vals$OIAA,vals$OIAB,vals$OIAG,vals$OIAF,vals$OIAH) * oneZoneStorage
    vals$OIAUploadCost <- calculateGrowthObj(vals$OIAStorageGB,vals$OIAF,vals$OIAH,vals$OIAObjPerGB,vals$OIAG,oneZonePUT)
    vals$OIADataTransferCost <- calculateDataRetrievalCosts(vals$OIAA,vals$OIAD,vals$OIAH,vals$OIAB,vals$OIAE,vals$OIAG,vals$OIAObjPerGB,vals$OIAF,oneZoneGET,oneZoneRetrieval,"None",1,1,1,1,1,1)

    vals$OIAMonthlyCost <- vals$OIAStorageCost + vals$OIAUploadCost + vals$OIADataTransferCost
    vals$OIACumulativeCost <- cumsum(vals$OIAMonthlyCost)

    vals$OIADf <- data.frame(vals$OIAMonths,vals$OIAStorageAmount,vals$OIAStorageCost,vals$OIAUploadCost,vals$OIADataTransferCost,vals$OIAMonthlyCost,vals$OIACumulativeCost)

    vals$glacierA <- as.numeric(paste(gsub("[^0-9.-]","",input$glacierStorage)))
    vals$glacierB <- input$glacierUnit1
    vals$glacierC <- as.numeric(paste(gsub("[^0-9.-]","",input$glacierObj)))
    vals$glacierD <- as.numeric(paste(gsub("[^0-9.-]","",input$glacierRetrieval)))
    vals$glacierE <- input$glacierUnit2
    vals$glacierF <- as.numeric(paste(gsub("[^0-9.-]","",input$glacierGrowth)))
    vals$glacierG <- input$glacierUnit3
    vals$glacierH <- input$glacierMonths
    vals$glacierI <- input$glacierSpeed
    vals$glacierJ <- input$copySelect4
    vals$glacierStorageGB <- calculateGB(vals$glacierA,vals$glacierB)
    vals$glacierRetrievalGB <- calculateGB(vals$glacierD,vals$glacierE)
    vals$glacierObjPerGB <- vals$glacierC / vals$glacierStorageGB
    vals$glacierMonths <- c(1:vals$glacierH)

    vals$glacierStorageAmount <- convertBack(calculateStorageAmount(vals$glacierA,vals$glacierB,vals$glacierG,vals$glacierF,vals$glacierH))
    vals$glacierStorageCost <- calculateStorageAmount(vals$glacierA,vals$glacierB,vals$glacierG,vals$glacierF,vals$glacierH) * glacierstorage
    vals$glacierUploadCost <- calculateGrowthObj(vals$glacierStorageGB,vals$glacierF,vals$glacierH,vals$glacierObjPerGB,vals$glacierG,glacierPUT)
    vals$glacierDataTransferCost <- calculateDataRetrievalCosts(vals$glacierA,vals$glacierD,vals$glacierH,vals$glacierB,vals$glacierE,vals$glacierG,vals$glacierObjPerGB,vals$glacierF,1,1,vals$glacierI,glacierRetrievalExpeditedReq,glacierRetrievalStandardReq,glacierRetrievalBulkReq,glacierRetrievalExpedited,glacierRetrievalStandard,glacierRetrievalBulk)

    vals$glacierMonthlyCost <- vals$glacierStorageCost + vals$glacierUploadCost + vals$glacierDataTransferCost
    vals$glacierCumulativeCost <- cumsum(vals$glacierMonthlyCost)

    vals$glacierDf <- data.frame(vals$glacierMonths,vals$glacierStorageAmount,vals$glacierStorageCost,vals$glacierUploadCost,vals$glacierDataTransferCost,vals$glacierMonthlyCost,vals$glacierCumulativeCost)

    vals$DAA <- as.numeric(paste(gsub("[^0-9.-]","",input$DAStorage)))
    vals$DAB <- input$DAUnit1
    vals$DAC <- as.numeric(paste(gsub("[^0-9.-]","",input$DAObj)))
    vals$DAD <- as.numeric(paste(gsub("[^0-9.-]","",input$DARetrieval)))
    vals$DAE <- input$DAUnit2
    vals$DAF <- as.numeric(paste(gsub("[^0-9.-]","",input$DAGrowth)))
    vals$DAG <- input$DAUnit3
    vals$DAH <- input$DAMonths
    vals$DAI <- input$DASpeed
    vals$DAJ <- input$copySelect5
    vals$DAStorageGB <- calculateGB(vals$DAA,vals$DAB)
    vals$DARetrievalGB <- calculateGB(vals$DAD,vals$DAE)
    vals$DAObjPerGB <- vals$DAC / vals$DAStorageGB
    vals$DAMonths <- c(1:vals$DAH)

    vals$DAStorageAmount <- convertBack(calculateStorageAmount(vals$DAA,vals$DAB,vals$DAG,vals$DAF,vals$DAH))
    vals$DAStorageCost <- calculateStorageAmount(vals$DAA,vals$DAB,vals$DAG,vals$DAF,vals$DAH) * deepGlacierStorage
    vals$DAUploadCost <- calculateGrowthObj(vals$DAStorageGB,vals$DAF,vals$DAH,vals$DAObjPerGB,vals$DAG,deepGlacierPUT)
    vals$DADataTransferCost <- calculateDataRetrievalCosts(vals$DAA,vals$DAD,vals$DAH,vals$DAB,vals$DAE,vals$DAG,vals$DAObjPerGB,vals$DAF,1,1,vals$DAI,1,deepGlacierRetrievalStandardReq,deepGlacierRetrievalBulkReq,1,deepGlacierRetrievalStandard,deepGlacierRetrievalBulk)

    vals$DAMonthlyCost <- vals$DAStorageCost + vals$DAUploadCost + vals$DADataTransferCost
    vals$DACumulativeCost <- cumsum(vals$DAMonthlyCost)

    vals$DADf <- data.frame(vals$DAMonths,vals$DAStorageAmount,vals$DAStorageCost,vals$DAUploadCost,vals$DADataTransferCost,vals$DAMonthlyCost,vals$DACumulativeCost)

    vals$compMonths <- input$compMonths
    vals$compMonthsDf <- c(1:vals$compMonths)

    vals$compStdStorage <- calculateStorageTier(calculateStorageCosts(vals$stdA,vals$stdB,vals$stdG,vals$stdF,vals$compMonths))
    vals$compStdUpload <- calculateGrowthObj(vals$stdStorageGB,vals$stdF,vals$compMonths,vals$stdObjPerGB,vals$stdG,standardPUT)
    vals$compStdDataTransfer <- calculateStdDataRetrievalCosts(vals$stdA,vals$stdD,vals$compMonths,vals$stdB,vals$stdE,vals$stdG,vals$stdObjPerGB,vals$stdF)
    vals$compStdStorageCumulative <- cumsum(vals$compStdStorage)
    vals$compStdUploadCumulative <- cumsum(vals$compStdUpload)
    vals$compStdDataTransferCumulative <- cumsum(vals$compStdDataTransfer)

    vals$compIAStorage <- calculateStorageAmount(vals$IAA,vals$IAB,vals$IAG,vals$IAF,vals$compMonths) * infrequentStorage
    vals$compIAUpload <- calculateGrowthObj(vals$IAStorageGB,vals$IAF,vals$compMonths,vals$IAObjPerGB,vals$IAG,infrequentPUT)
    vals$compIADataTransfer <- calculateDataRetrievalCosts(vals$IAA,vals$IAD,vals$compMonths,vals$IAB,vals$IAE,vals$IAG,vals$IAObjPerGB,vals$IAF,infrequentGET,infrequentRetrieval,"None",1,1,1,1,1,1)
    vals$compIAStorageCumulative <- cumsum(vals$compIAStorage)
    vals$compIAUploadCumulative <- cumsum(vals$compIAUpload)
    vals$compIADataTransferCumulative <- cumsum(vals$compIADataTransfer)

    vals$compOIAStorage <- calculateStorageAmount(vals$OIAA,vals$OIAB,vals$OIAG,vals$OIAF,vals$compMonths) * oneZoneStorage
    vals$compOIAUpload <- calculateGrowthObj(vals$OIAStorageGB,vals$OIAF,vals$compMonths,vals$OIAObjPerGB,vals$OIAG,oneZonePUT)
    vals$compOIADataTransfer <- calculateDataRetrievalCosts(vals$OIAA,vals$OIAD,vals$compMonths,vals$OIAB,vals$OIAE,vals$OIAG,vals$OIAObjPerGB,vals$OIAF,oneZoneGET,oneZoneRetrieval,"None",1,1,1,1,1,1)
    vals$compOIAStorageCumulative <- cumsum(vals$compOIAStorage)
    vals$compOIAUploadCumulative <- cumsum(vals$compOIAUpload)
    vals$compOIADataTransferCumulative <- cumsum(vals$compOIADataTransfer)

    vals$compGlacierStorage <- calculateStorageAmount(vals$glacierA,vals$glacierB,vals$glacierG,vals$glacierF,vals$compMonths) * glacierstorage
    vals$compGlacierUpload <- calculateGrowthObj(vals$glacierStorageGB,vals$glacierF,vals$compMonths,vals$glacierObjPerGB,vals$glacierG,glacierPUT)
    vals$compGlacierDataTransfer <- calculateDataRetrievalCosts(vals$glacierA,vals$glacierD,vals$compMonths,vals$glacierB,vals$glacierE,vals$glacierG,vals$glacierObjPerGB,vals$glacierF,1,1,vals$glacierI,glacierRetrievalExpeditedReq,glacierRetrievalStandardReq,glacierRetrievalBulkReq,glacierRetrievalExpedited,glacierRetrievalStandard,glacierRetrievalBulk)
    vals$compGlacierStorageCumulative <- cumsum(vals$compGlacierStorage)
    vals$compGlacierUploadCumulative <- cumsum(vals$compGlacierUpload)
    vals$compGlacierDataTransferCumulative <- cumsum(vals$compGlacierDataTransfer)

    vals$compDAStorage <- calculateStorageAmount(vals$DAA,vals$DAB,vals$DAG,vals$DAF,vals$compMonths) * deepGlacierStorage
    vals$compDAUpload <- calculateGrowthObj(vals$DAStorageGB,vals$DAF,vals$compMonths,vals$DAObjPerGB,vals$DAG,deepGlacierPUT)
    vals$compDADataTransfer <- calculateDataRetrievalCosts(vals$DAA,vals$DAD,vals$compMonths,vals$DAB,vals$DAE,vals$DAG,vals$DAObjPerGB,vals$DAF,1,1,vals$DAI,1,deepGlacierRetrievalStandardReq,deepGlacierRetrievalBulkReq,1,deepGlacierRetrievalStandard,deepGlacierRetrievalBulk)
    vals$compDAStorageCumulative <- cumsum(vals$compDAStorage)
    vals$compDAUploadCumulative <- cumsum(vals$compDAUpload)
    vals$compDADataTransferCumulative <- cumsum(vals$compDADataTransfer)

    vals$compStdMonthly <- vals$compStdStorage + vals$compStdUpload + vals$compStdDataTransfer
    vals$compStdCumulative <- cumsum(vals$compStdMonthly)

    vals$compIAMonthly <- vals$compIAStorage + vals$compIAUpload + vals$compIADataTransfer
    vals$compIACumulative <- cumsum(vals$compIAMonthly)

    vals$compOIAMonthly <- vals$compOIAStorage + vals$compOIAUpload + vals$compOIADataTransfer
    vals$compOIACumulative <- cumsum(vals$compOIAMonthly)

    vals$compGlacierMonthly <- vals$compGlacierStorage + vals$compGlacierUpload + vals$compGlacierDataTransfer
    vals$compGlacierCumulative <- cumsum(vals$compGlacierMonthly)

    vals$compDAMonthly <- vals$compDAStorage + vals$compDAUpload + vals$compDADataTransfer
    vals$compDACumulative <- cumsum(vals$compDAMonthly)

    vals$compStorageDf <- data.frame(vals$compMonthsDf,vals$compStdStorageCumulative,vals$compIAStorageCumulative,vals$compOIAStorageCumulative,vals$compGlacierStorageCumulative,vals$compDAStorageCumulative)
    vals$compUploadDf <- data.frame(vals$compMonthsDf,vals$compStdUploadCumulative,vals$compIAUploadCumulative,vals$compOIAUploadCumulative,vals$compGlacierUploadCumulative,vals$compDAUploadCumulative)
    vals$compDataRetrievalDf <- data.frame(vals$compMonthsDf,vals$compStdDataTransferCumulative,vals$compIADataTransferCumulative,vals$compOIADataTransferCumulative,vals$compGlacierDataTransferCumulative,vals$compDADataTransferCumulative)
    vals$compTotalsDf <- data.frame(vals$compMonthsDf,vals$compStdCumulative,vals$compIACumulative,vals$compOIACumulative,vals$compGlacierCumulative,vals$compDACumulative)

  })

  compHeaders <- c("Month","Standard Cost","Infrequent Access Cost","One Zone-IA Cost","Glacier Cost","Glacier-Deep Archive Cost")

  updateStdInputs <- function(storage,unit1,obj,retrieval,unit2,growth,unit3,months){
    updateTextInput(session,"stdStorage",value=storage)
    updateSelectInput(session,"stdUnit1",selected=unit1)
    updateTextInput(session,"stdObj",value=obj)
    updateTextInput(session,"stdRetrieval",value=retrieval)
    updateSelectInput(session,"stdUnit2",selected=unit2)
    updateTextInput(session,"stdGrowth",value=growth)
    updateSelectInput(session,"stdUnit3",selected=unit3)
    updateSliderInput(session,"stdMonths",value=months)

  }

  updateIAInputs <- function(storage,unit1,obj,retrieval,unit2,growth,unit3,months){
    updateTextInput(session,"IAStorage",value=storage)
    updateSelectInput(session,"IAUnit1",selected=unit1)
    updateTextInput(session,"IAObj",value=obj)
    updateTextInput(session,"IARetrieval",value=retrieval)
    updateSelectInput(session,"IAUnit2",selected=unit2)
    updateTextInput(session,"IAGrowth",value=growth)
    updateSelectInput(session,"IAUnit3",selected=unit3)
    updateSliderInput(session,"IAMonths",value=months)
  }

  updateOIAInputs <- function(storage,unit1,obj,retrieval,unit2,growth,unit3,months){
    updateTextInput(session,"OIAStorage",value=storage)
    updateSelectInput(session,"OIAUnit1",selected=unit1)
    updateTextInput(session,"OIAObj",value=obj)
    updateTextInput(session,"OIARetrieval",value=retrieval)
    updateSelectInput(session,"OIAUnit2",selected=unit2)
    updateTextInput(session,"OIAGrowth",value=growth)
    updateSelectInput(session,"OIAUnit3",selected=unit3)
    updateSliderInput(session,"OIAMonths",value=months)
  }

  updateGlacierInputs <- function(storage,unit1,obj,retrieval,unit2,growth,unit3,months){
    updateTextInput(session,"glacierStorage",value=storage)
    updateSelectInput(session,"glacierUnit1",selected=unit1)
    updateTextInput(session,"glacierObj",value=obj)
    updateTextInput(session,"glacierRetrieval",value=retrieval)
    updateSelectInput(session,"glacierUnit2",selected=unit2)
    updateTextInput(session,"glacierGrowth",value=growth)
    updateSelectInput(session,"glacierUnit3",selected=unit3)
    updateSliderInput(session,"glacierMonths",value=months)
  }

  updateDAInputs <- function(storage,unit1,obj,retrieval,unit2,growth,unit3,months){
    updateTextInput(session,"DAStorage",value=storage)
    updateSelectInput(session,"DAUnit1",selected=unit1)
    updateTextInput(session,"DAObj",value=obj)
    updateTextInput(session,"DARetrieval",value=retrieval)
    updateSelectInput(session,"DAUnit2",selected=unit2)
    updateTextInput(session,"DAGrowth",value=growth)
    updateSelectInput(session,"DAUnit3",selected=unit3)
    updateSliderInput(session,"DAMonths",value=months)
  }

  observeEvent(input$clr1, {
    updateTextInput(session,"stdStorage",value="0")
    updateTextInput(session,"stdObj",value="0")
    updateTextInput(session,"stdRetrieval",value="0")
    updateTextInput(session,"stdGrowth",value="0")
    updateSliderInput(session,"stdMonths",value=3)
  })

  observeEvent(input$copy1, {
    if(vals$stdI == "All"){
      updateIAInputs(vals$stdA,vals$stdB,vals$stdC,vals$stdD,vals$stdE,vals$stdF,vals$stdG,vals$stdH)
      updateOIAInputs(vals$stdA,vals$stdB,vals$stdC,vals$stdD,vals$stdE,vals$stdF,vals$stdG,vals$stdH)
      updateGlacierInputs(vals$stdA,vals$stdB,vals$stdC,vals$stdD,vals$stdE,vals$stdF,vals$stdG,vals$stdH)
      updateDAInputs(vals$stdA,vals$stdB,vals$stdC,vals$stdD,vals$stdE,vals$stdF,vals$stdG,vals$stdH)
    }else if(vals$stdI == "Infrequent Access"){
      updateIAInputs(vals$stdA,vals$stdB,vals$stdC,vals$stdD,vals$stdE,vals$stdF,vals$stdG,vals$stdH)
    }else if(vals$stdI == "One Zone-IA"){
      updateOIAInputs(vals$stdA,vals$stdB,vals$stdC,vals$stdD,vals$stdE,vals$stdF,vals$stdG,vals$stdH)
    }else if(vals$stdI == "Glacier"){
      updateGlacierInputs(vals$stdA,vals$stdB,vals$stdC,vals$stdD,vals$stdE,vals$stdF,vals$stdG,vals$stdH)
    }else if(vals$stdI == "Glacier-Deep Archive"){
      updateDAInputs(vals$stdA,vals$stdB,vals$stdC,vals$stdD,vals$stdE,vals$stdF,vals$stdG,vals$stdH)
    }
  })

  observeEvent(input$clr2, {
    updateTextInput(session,"IAStorage",value="0")
    updateTextInput(session,"IAObj",value="0")
    updateTextInput(session,"IARetrieval",value="0")
    updateTextInput(session,"IAGrowth",value="0")
    updateSliderInput(session,"IAMonths",value=3)
  })

  observeEvent(input$copy2, {
    if(vals$IAI == "All"){
      updateStdInputs(vals$IAA,vals$IAB,vals$IAC,vals$IAD,vals$IAE,vals$IAF,vals$IAG,vals$IAH)
      updateOIAInputs(vals$IAA,vals$IAB,vals$IAC,vals$IAD,vals$IAE,vals$IAF,vals$IAG,vals$IAH)
      updateGlacierInputs(vals$IAA,vals$IAB,vals$IAC,vals$IAD,vals$IAE,vals$IAF,vals$IAG,vals$IAH)
      updateDAInputs(vals$IAA,vals$IAB,vals$IAC,vals$IAD,vals$IAE,vals$IAF,vals$IAG,vals$IAH)
    }else if(vals$IAI == "Standard"){
      updateStdInputs(vals$IAA,vals$IAB,vals$IAC,vals$IAD,vals$IAE,vals$IAF,vals$IAG,vals$IAH)
    }else if(vals$IAI == "One Zone-IA"){
      updateOIAInputs(vals$IAA,vals$IAB,vals$IAC,vals$IAD,vals$IAE,vals$IAF,vals$IAG,vals$IAH)
    }else if(vals$IAI == "Glacier"){
      updateGlacierInputs(vals$IAA,vals$IAB,vals$IAC,vals$IAD,vals$IAE,vals$IAF,vals$IAG,vals$IAH)
    }else if(vals$IAI == "Glacier-Deep Glacier"){
      updateDAInputs(vals$IAA,vals$IAB,vals$IAC,vals$IAD,vals$IAE,vals$IAF,vals$IAG,vals$IAH)
    }
  })

  observeEvent(input$clr3, {
    updateTextInput(session,"OIAStorage",value="0")
    updateTextInput(session,"OIAObj",value="0")
    updateTextInput(session,"OIARetrieval",value="0")
    updateTextInput(session,"OIAGrowth",value="0")
    updateSliderInput(session,"OIAMonths",value=3)
  })

  observeEvent(input$copy3, {
    if(vals$OIAI == "All"){
      updateStdInputs(vals$OIAA,vals$OIAB,vals$OIAC,vals$OIAD,vals$OIAE,vals$OIAF,vals$OIAG,vals$OIAH)
      updateIAInputs(vals$OIAA,vals$OIAB,vals$OIAC,vals$OIAD,vals$OIAE,vals$OIAF,vals$OIAG,vals$OIAH)
      updateGlacierInputs(vals$OIAA,vals$OIAB,vals$OIAC,vals$OIAD,vals$OIAE,vals$OIAF,vals$OIAG,vals$OIAH)
      updateDAInputs(vals$OIAA,vals$OIAB,vals$OIAC,vals$OIAD,vals$OIAE,vals$OIAF,vals$OIAG,vals$OIAH)
    }else if(vals$OIAI == "Standard"){
      updateStdInputs(vals$OIAA,vals$OIAB,vals$OIAC,vals$OIAD,vals$OIAE,vals$OIAF,vals$OIAG,vals$OIAH)
    }else if(vals$OIAI == "Infrequent Access"){
      updateIAInputs(vals$OIAA,vals$OIAB,vals$OIAC,vals$OIAD,vals$OIAE,vals$OIAF,vals$OIAG,vals$OIAH)
    }else if(vals$OIAI == "Glacier"){
      updateGlacierInputs(vals$OIAA,vals$OIAB,vals$OIAC,vals$OIAD,vals$OIAE,vals$OIAF,vals$OIAG,vals$OIAH)
    }else if(vals$OIAI == "Glacier-Deep Glacier"){
      updateDAInputs(vals$OIAA,vals$OIAB,vals$OIAC,vals$OIAD,vals$OIAE,vals$OIAF,vals$OIAG,vals$OIAH)
    }
  })

  observeEvent(input$clr4, {
    updateTextInput(session,"glacierStorage",value="0")
    updateTextInput(session,"glacierObj",value="0")
    updateTextInput(session,"glacierRetrieval",value="0")
    updateTextInput(session,"glacierGrowth",value="0")
    updateSliderInput(session,"glacierMonths",value=3)
  })

  observeEvent(input$copy4, {
    if(vals$glacierJ == "All"){
      updateStdInputs(vals$glacierA,vals$glacierB,vals$glacierC,vals$glacierD,vals$glacierE,vals$glacierF,vals$glacierG,vals$glacierH)
      updateIAInputs(vals$glacierA,vals$glacierB,vals$glacierC,vals$glacierD,vals$glacierE,vals$glacierF,vals$glacierG,vals$glacierH)
      updateOIAInputs(vals$glacierA,vals$glacierB,vals$glacierC,vals$glacierD,vals$glacierE,vals$glacierF,vals$glacierG,vals$glacierH)
      updateDAInputs(vals$glacierA,vals$glacierB,vals$glacierC,vals$glacierD,vals$glacierE,vals$glacierF,vals$glacierG,vals$glacierH)
    }else if(vals$glacierJ == "Standard"){
      updateStdInputs(vals$glacierA,vals$glacierB,vals$glacierC,vals$glacierD,vals$glacierE,vals$glacierF,vals$glacierG,vals$glacierH)
    }else if(vals$glacierJ == "Infrequent Access"){
      updateStdInputs(vals$glacierA,vals$glacierB,vals$glacierC,vals$glacierD,vals$glacierE,vals$glacierF,vals$glacierG,vals$glacierH)
    }else if(vals$glacierJ == "One Zone-IA"){
      updateOIAInputs(vals$glacierA,vals$glacierB,vals$glacierC,vals$glacierD,vals$glacierE,vals$glacierF,vals$glacierG,vals$glacierH)
    }else if(vals$glacierJ == "Glacier-Deep Archive"){
      updateDAInputs(vals$glacierA,vals$glacierB,vals$glacierC,vals$glacierD,vals$glacierE,vals$glacierF,vals$glacierG,vals$glacierH)
    }
  })

  observeEvent(input$clr5, {
    updateTextInput(session,"DAStorage",value="0")
    updateTextInput(session,"DAObj",value="0")
    updateTextInput(session,"DARetrieval",value="0")
    updateTextInput(session,"DAGrowth",value="0")
    updateSliderInput(session,"DAMonths",value=3)
  })

  observeEvent(input$copy5, {
    if(vals$DAJ == "All"){
      updateStdInputs(vals$DAA,vals$DAB,vals$DAC,vals$DAD,vals$DAE,vals$DAF,vals$DAG,vals$DAH)
      updateIAInputs(vals$DAA,vals$DAB,vals$DAC,vals$DAD,vals$DAE,vals$DAF,vals$DAG,vals$DAH)
      updateOIAInputs(vals$DAA,vals$DAB,vals$DAC,vals$DAD,vals$DAE,vals$DAF,vals$DAG,vals$DAH)
      updateGlacierInputs(vals$DAA,vals$DAB,vals$DAC,vals$DAD,vals$DAE,vals$DAF,vals$DAG,vals$DAH)
    }else if(vals$DAJ == "Standard"){
      updateStdInputs(vals$DAA,vals$DAB,vals$DAC,vals$DAD,vals$DAE,vals$DAF,vals$DAG,vals$DAH)
    }else if(vals$DAJ == "Infrequent Access"){
      updateIAInputs(vals$DAA,vals$DAB,vals$DAC,vals$DAD,vals$DAE,vals$DAF,vals$DAG,vals$DAH)
    }else if(vals$DAJ == "One Zone-IA"){
      updateOIAInputs(vals$DAA,vals$DAB,vals$DAC,vals$DAD,vals$DAE,vals$DAF,vals$DAG,vals$DAH)
    }else if(vals$DAJ == "Glacier"){
      updateGlacierInputs(vals$DAA,vals$DAB,vals$DAC,vals$DAD,vals$DAE,vals$DAF,vals$DAG,vals$DAH)
    }
  })

  observeEvent(input$storageShow, {
    storage <- rep(T,vals$compMonths)
  })

  observeEvent(input$storageHide, {
    storageHide <- rep(F,vals$compMonths)
  })

  observeEvent(input$storageOnly, {
    storage <- rep(T,vals$compMonths)
    upload <- rep(F,vals$compMonths)
    retrieval <- rep(F,vals$compMonths)
  })

  observeEvent(input$uploadShow, {
    upload <- rep(T,vals$compMonths)
  })

  observeEvent(input$uploadHide, {
    upload <- rep(F,vals$compMonths)
  })

  observeEvent(input$uploadOnly, {
    storage <- rep(F,vals$compMonths)
    upload <- rep(T,vals$compMonths)
    retrieval <- rep(F,vals$compMonths)
  })

  observeEvent(input$retrievalShow, {
    retrieval <- rep(T,vals$compMonths)
  })

  observeEvent(input$retrievalHide, {
    retrieval <- rep(F,vals$compMonths)
  })

  observeEvent(input$retrievalOnly, {
    storage <- rep(F,vals$compMonths)
    upload <- rep(F,vals$compMonths)
    retrieval <- rep(T,vals$compMonths)
  })

  output$stdPlot <- renderPlot({

    qplot(xlab="\nMonth",ylab="Monthly Cost ($)\n")+
      geom_line(aes(x=c(1:vals$stdH),y=vals$stdStorageCost,color='Storage Cost'),size=I(2))+
      geom_line(aes(x=c(1:vals$stdH),y=vals$stdUploadCost,color='Upload Cost'),size=I(2))+
      geom_line(aes(x=c(1:vals$stdH),vals$stdDataTransferCost,color='Data Retrieval Cost'),size=I(2))+
      scale_x_continuous(breaks=seq(1,vals$stdH,by=1))+
      theme(text=element_text(size=15))+
      theme(legend.text=element_text(size=13))+
      theme(legend.key.size=unit(2,"line"))+
      scale_color_manual(values=c("Storage Cost"="#B32F2F","Upload Cost"="#CE5858","Data Retrieval Cost"="#DE8F8F"))+
      labs(color='')

  })

  output$stdTable <- renderTable({
    names(vals$stdDf) <- headers
    vals$stdDf
  },align='c',spacing='xs')

  output$IAPlot <- renderPlot({

    qplot(xlab="\nMonth",ylab="Monthly Cost ($)\n")+
      geom_line(aes(x=c(1:vals$IAH),y=vals$IAStorageCost,color='Storage Cost'),size=I(2))+
      geom_line(aes(x=c(1:vals$IAH),y=vals$IAUploadCost,color='Upload Cost'),size=I(2))+
      geom_line(aes(x=c(1:vals$IAH),vals$IADataTransferCost,color='Data Retrieval Cost'),size=I(2))+
      scale_x_continuous(breaks=seq(1,vals$IAH,by=1))+
      theme(text=element_text(size=15))+
      theme(legend.text=element_text(size=13))+
      theme(legend.key.size=unit(2,"line"))+
      scale_color_manual(values=c("Storage Cost"="#306B19","Upload Cost"="#419222","Data Retrieval Cost"="#86B972"))+
      labs(color='')

  })

  output$IATable <- renderTable({
    names(vals$IADf) <- headers
    vals$IADf
  },align='c',spacing='xs')

  output$OIAPlot <- renderPlot({

    qplot(xlab="\nMonth",ylab="Monthly Cost ($)\n")+
      geom_line(aes(x=c(1:vals$OIAH),y=vals$OIAStorageCost,color='Storage Cost'),size=I(2))+
      geom_line(aes(x=c(1:vals$OIAH),y=vals$OIAUploadCost,color='Upload Cost'),size=I(2))+
      geom_line(aes(x=c(1:vals$OIAH),vals$OIADataTransferCost,color='Data Retrieval Cost'),size=I(2))+
      scale_x_continuous(breaks=seq(1,vals$OIAH,by=1))+
      theme(text=element_text(size=15))+
      theme(legend.text=element_text(size=13))+
      theme(legend.key.size=unit(2,"line"))+
      scale_color_manual(values=c("Storage Cost"="#09332D","Upload Cost"="#136F63","Data Retrieval Cost"="#93BDB8"))+
      labs(color='')

  })

  output$OIATable <- renderTable({
    names(vals$OIADf) <- headers
    vals$OIADf
  },align='c',spacing='xs')

  output$glacierTable <- renderTable({
    names(vals$glacierDf) <- headers
    vals$glacierDf
  },align='c',spacing='xs')

  output$glacierPlot <- renderPlot({

    qplot(xlab="\nMonth",ylab="Monthly Cost ($)\n")+
      geom_line(aes(x=c(1:vals$glacierH),y=vals$glacierStorageCost,color='Storage Cost'),size=I(2))+
      geom_line(aes(x=c(1:vals$glacierH),y=vals$glacierUploadCost,color='Upload Cost'),size=I(2))+
      geom_line(aes(x=c(1:vals$glacierH),vals$glacierDataTransferCost,color='Data Retrieval Cost'),size=I(2))+
      scale_x_continuous(breaks=seq(1,vals$glacierH,by=1))+
      theme(text=element_text(size=15))+
      theme(legend.text=element_text(size=13))+
      theme(legend.key.size=unit(2,"line"))+
      scale_color_manual(values=c("Storage Cost"="#1D3E5A","Upload Cost"="#3F88C5","Data Retrieval Cost"="#A7C8E4"))+
      labs(color='')

  })

  output$DATable <- renderTable({
    names(vals$DADf) <- headers
    vals$DADf
  },align='c',spacing='xs')

  output$DAPlot <- renderPlot({

    qplot(xlab="\nMonth",ylab="Monthly Cost ($)\n")+
      geom_line(aes(x=c(1:vals$DAH),y=vals$DAStorageCost,color='Storage Cost'),size=I(2))+
      geom_line(aes(x=c(1:vals$DAH),y=vals$DAUploadCost,color='Upload Cost'),size=I(2))+
      geom_line(aes(x=c(1:vals$DAH),vals$DADataTransferCost,color='Data Retrieval Cost'),size=I(2))+
      scale_x_continuous(breaks=seq(1,vals$DAH,by=1))+
      theme(text=element_text(size=15))+
      theme(legend.text=element_text(size=13))+
      theme(legend.key.size=unit(2,"line"))+
      scale_color_manual(values=c("Storage Cost"="#6B5565","Upload Cost"="#93748A","Data Retrieval Cost"="#BAA6B4"))+
      labs(color='')

  })

  output$compPlotStorage <- renderPlot({

    qplot(xlab="\nMonth",ylab="Cumulative Cost ($)\n")+
      geom_line(aes(x=c(1:vals$compMonths),y=vals$compStdStorageCumulative,color='Standard'),size=I(2))+
      geom_line(aes(x=c(1:vals$compMonths),y=vals$compIAStorageCumulative,color='Infrequent Access'),size=I(2))+
      geom_line(aes(x=c(1:vals$compMonths),y=vals$compOIAStorageCumulative,color='One Zone-IA'),size=I(2))+
      geom_line(aes(x=c(1:vals$compMonths),y=vals$compGlacierStorageCumulative,color='Glacier'),size=I(2))+
      geom_line(aes(x=c(1:vals$compMonths),y=vals$compDAStorageCumulative,color='Glacier-Deep Archive'),size=I(2))+
      scale_x_continuous(breaks=seq(1,vals$compMonths,by=1))+
      theme(text=element_text(size=15))+
      theme(legend.text=element_text(size=13))+
      theme(legend.key.size=unit(2,"line"))+
      scale_color_manual(values=c("Standard"="#CE5858","Infrequent Access"="#419222","One Zone-IA"="#136F63","Glacier"="#3F88C5","Glacier-Deep Archive"="#93748A"))+
      labs(color='')

  })

  output$compTableStorage <- renderTable({
    names(vals$compStorageDf) <- compHeaders
    vals$compStorageDf
  },align='c',spacing='xs')

  output$compPlotUpload <- renderPlot({

    qplot(xlab="\nMonth",ylab="Cumulative Cost ($)\n")+
      geom_line(aes(x=c(1:vals$compMonths),y=vals$compStdUploadCumulative,color='Standard'),size=I(2))+
      geom_line(aes(x=c(1:vals$compMonths),y=vals$compIAUploadCumulative,color='Infrequent Access'),size=I(2))+
      geom_line(aes(x=c(1:vals$compMonths),y=vals$compOIAUploadCumulative,color='One Zone-IA'),size=I(2))+
      geom_line(aes(x=c(1:vals$compMonths),y=vals$compGlacierUploadCumulative,color='Glacier'),size=I(2))+
      geom_line(aes(x=c(1:vals$compMonths),y=vals$compDAUploadCumulative,color='Glacier-Deep Archive'),size=I(2))+
      scale_x_continuous(breaks=seq(1,vals$compMonths,by=1))+
      theme(text=element_text(size=15))+
      theme(legend.text=element_text(size=13))+
      theme(legend.key.size=unit(2,"line"))+
      scale_color_manual(values=c("Standard"="#CE5858","Infrequent Access"="#419222","One Zone-IA"="#136F63","Glacier"="#3F88C5","Glacier-Deep Archive"="#93748A"))+
      labs(color='')

  })

  output$compTableUpload <- renderTable({
    names(vals$compUploadDf) <- compHeaders
    vals$compUploadDf
  },align='c',spacing='xs')

  output$compPlotDataRetrieval <- renderPlot({

    qplot(xlab="\nMonth",ylab="Cumulative Cost ($)\n")+
      geom_line(aes(x=c(1:vals$compMonths),y=vals$compStdDataTransferCumulative,color='Standard'),size=I(2))+
      geom_line(aes(x=c(1:vals$compMonths),y=vals$compIADataTransferCumulative,color='Infrequent Access'),size=I(2))+
      geom_line(aes(x=c(1:vals$compMonths),y=vals$compOIADataTransferCumulative,color='One Zone-IA'),size=I(2))+
      geom_line(aes(x=c(1:vals$compMonths),y=vals$compGlacierDataTransferCumulative,color='Glacier'),size=I(2))+
      geom_line(aes(x=c(1:vals$compMonths),y=vals$compDADataTransferCumulative,color='Glacier-Deep Archive'),size=I(2))+
      scale_x_continuous(breaks=seq(1,vals$compMonths,by=1))+
      theme(text=element_text(size=15))+
      theme(legend.text=element_text(size=13))+
      theme(legend.key.size=unit(2,"line"))+
      scale_color_manual(values=c("Standard"="#CE5858","Infrequent Access"="#419222","One Zone-IA"="#136F63","Glacier"="#3F88C5","Glacier-Deep Archive"="#93748A"))+
      labs(color='')

  })

  output$compTableDataRetrieval <- renderTable({
    names(vals$compDataRetrievalDf) <- compHeaders
    vals$compDataRetrievalDf
  },align='c',spacing='xs')

  output$compPlotTotals <- renderPlot({

    qplot(xlab="\nMonth",ylab="Cumulative Cost ($)\n")+
      geom_line(aes(x=c(1:vals$compMonths),y=vals$compStdCumulative,color='Standard'),size=I(2))+
      geom_line(aes(x=c(1:vals$compMonths),y=vals$compIACumulative,color='Infrequent Access'),size=I(2))+
      geom_line(aes(x=c(1:vals$compMonths),y=vals$compOIACumulative,color='One Zone-IA'),size=I(2))+
      geom_line(aes(x=c(1:vals$compMonths),y=vals$compGlacierCumulative,color='Glacier'),size=I(2))+
      geom_line(aes(x=c(1:vals$compMonths),y=vals$compDACumulative,color='Glacier-Deep Archive'),size=I(2))+
      scale_x_continuous(breaks=seq(1,vals$compMonths,by=1))+
      theme(text=element_text(size=15))+
      theme(legend.text=element_text(size=13))+
      theme(legend.key.size=unit(2,"line"))+
      scale_color_manual(values=c("Standard"="#CE5858","Infrequent Access"="#419222","One Zone-IA"="#136F63","Glacier"="#3F88C5","Glacier-Deep Archive"="#93748A"))+
      labs(color='')

  })

  output$compTableTotals <- renderTable({
    names(vals$compTotalsDf) <- compHeaders
    vals$compTotalsDf
  },align='c',spacing='xs')

}


library(ggplot2)
library(data.table)
library(rstan)
library(bayesplot)
options(mc.cores = parallel::detectCores())
rstan_options(auto_write=TRUE)

tsuga = readRDS("exercises/data/tsuga_spatial.rds")

xvars = as.matrix(tsuga[, .(annual_mean_temp, tot_annual_pp)])
xvars = scale(xvars)

# transform coordinates to be a little easier to fit
# note that the scale must be the same for X and Y, so that
# we can continue to interpret them as being in distance units
coords = as.matrix(tsuga[, .(X, Y)])
coords = coords/100000 ## convert to 100 km
coords = apply(coords, 2, function(x) x - min(x)) ## set the minimum to zero

## two different datasets, one with precip, one without
standat = list(
	n = nrow(tsuga),
	died = tsuga$died,
	ntrees = tsuga$n,
	x = xvars[,1,drop=FALSE],
	coords = coords
)
standat$k = ncol(standat$x)
standat_pp = standat
standat_pp$x = xvars
standat_pp$k = ncol(standat_pp$x)

## this was run to assess convergence, but it's too big to work with
# models = list(
# 	mod_t = stan("../R/tsuga_nonspatial.stan", data = standat, chains = 1, iter=10000),
# 	mod_gp = stan("../R/tsuga_gp_only.stan", data = standat, chains = 4, iter=50000,
# 		control=list(adapt_delta = 0.94)),
# 	mod_gp_t = stan("../R/tsuga_gp_env.stan", data = standat, chains = 4, iter=50000,
# 		control=list(adapt_delta = 0.9)),
# 	mod_gp_tp = stan("../R/tsuga_gp_env.stan", data = standat_pp, chains = 4, iter=50000,
# 		control=list(adapt_delta = 0.9)))

models = list(
	mod_t = stan("../R/tsuga_nonspatial.stan", data = standat, chains = 1, iter=10000),
	mod_gp = stan("../R/tsuga_gp_only.stan", data = standat, chains = 1, iter=50000,
		control=list(adapt_delta = 0.94)),
	mod_gp_t = stan("../R/tsuga_gp_env.stan", data = standat, chains = 1, iter=50000,
		control=list(adapt_delta = 0.9)),
	mod_gp_tp = stan("../R/tsuga_gp_env.stan", data = standat_pp, chains = 1, iter=50000,
		control=list(adapt_delta = 0.9)))

# if this ends with an error, try reducing iter for the last 3 models to 25000
loos = lapply(models, loo, pars="loglik")

dir.create("../scratch")
saveRDS(models, "../scratch/gp_models.rds")
saveRDS(loos, "../scratch/gp_loos.rds")
saveRDS(standat, "../scratch/standat.rds")
saveRDS(standat_pp, "../scratch/standat_pp.rds")


df <- read.table("ftp://aftp.cmdl.noaa.gov/products/trends/co2/co2_mm_mlo.txt", header = FALSE, skip = 51)
co2 <- ts(data = df$V5, start=c(1958,3), frequency=12)
fit <- stl(co2, s.window=5)
plot(co2, col="gray", main="Atmospheric CO2", ylab="ppm", xlab="")
lines(fit$time.series[,2],col="red",ylab="Trend")
plot(fit)
monthplot(fit$time.series[,"seasonal"], main="", ylab="Seasonal")
fcast <- forecast::forecast(fit, h = 12 * 10)
plot(fcast, ylab="ppm")


# Transaction commission fee is 0.1425%.
# Seller must also pay 0.3% government tax.
long <- function(price) {
    return(price * (1 + 0.001425))
}

short <- function(price) {
    return(price * (1 - 0.001425 - 0.003))
}


 ZGTTRF Example Program Results

 Details of factorization

  Second superdiagonal of U
 (  2.0000,  1.0000) ( -1.0000,  1.0000) (  1.0000, -1.0000)

  First superdiagonal of U
 ( -1.3000,  1.3000) ( -1.3000,  3.3000) ( -0.3000,  4.3000) ( -3.3000,  1.3000)

  Main diagonal of U
 (  1.0000, -2.0000) (  1.0000,  1.0000) (  2.0000, -3.0000) (  1.0000,  1.0000)
 ( -1.3399,  0.2875)

  Multipliers
 ( -0.7800, -0.2600) (  0.1620, -0.4860) ( -0.0452, -0.0010) ( -0.3979, -0.0562)

  Vector of interchanges
       2      3      4      5      5


# Generate and plot Brownian tree. Version #4.
# 7/27/16 aev
# gpBrownianTree4(m, n, clr, fn, ttl, dflg, seed, psz)
# Where: m - defines matrix m x m; n - limit of the number of moves;
#   fn - file name (.ext will be added); ttl - plot title; dflg - 0-no dump,
#   1-dump; seed - 0-center, 1-random: psz - picture size.
gpBrownianTree4 <- function(m, n, clr, fn, ttl, dflg=0, seed=0, psz=600)
{
  cat(" *** START:", date(), "m=",m, "n=",n, "clr=",clr, "psz=",psz, "\n");
  M <- matrix(c(0), ncol=m, nrow=m, byrow=TRUE);
  # Random seed
  if(seed==1)
    {x <- sample(1:m, 1, replace=FALSE);y <- sample(1:m, 1, replace=FALSE)}
  # Seed in center
  else {x <- m%/%2; y <- m%/%2}
  M[x,y]=1;
  pf=paste0(fn,".png");
  cat(" *** Plot file -",pf,"Seed:",x,"/",y,"\n");
  # Main loops
  for (i in 1:n) {
    if(i>1) {
      x <- sample(1:m, 1, replace=FALSE)
      y <- sample(1:m, 1, replace=FALSE)}
    while((x<=m && y<=m && x>0 && y>0)) {
      if(!(x+1<=m && y+1<=m && x-1>0 && y-1>0)) {break;}
      b=M[x+1,y+1]+M[x,y+1]+M[x-1,y+1]+M[x+1,y];
      b=b+M[x-1,y-1]+M[x-1,y]+M[x,y-1]+M[x+1,y-1];
      if(b!=0) {break;}
      x <- x + sample(-1:1, 1, replace=FALSE)
      y <- y + sample(-1:1, 1, replace=FALSE)
      if(!(x<=m && y<=m && x>0 && y>0))
        { x <- sample(1:m, 1, replace=FALSE)
          y <- sample(1:m, 1, replace=FALSE)
        }
    }
    M[x,y]=1;
  }
  plotmat(M, fn, clr, ttl, dflg, psz);
  cat(" *** END:",date(),"\n");
}
gpBrownianTree4(400,15000,"navy", "BT4R", "Brownian Tree v.4", 1);


library('ggplot2')

#ggplot(data=mtcars, aes(x=disp, y=mpg)) + geom_point(aes(size=hp, color=wt))
ggplot(data=mtcars, aes(x=disp, y=mpg)) + geom_point(aes(size=hp, color=wt))
p <- gplot(data=mtcars, aes(x=disp, y=mpg, size=hp, color=wt)) + geom_point()
p + stat_smooth(color='black', fill='grey')


function(dlist, sjs=NA){
#This function reads a list object containing data from a
#Crazy Beliefs experiment, in the format read in by
#get.data. Each element of the list corresponds to a different
#subject, and contains a sub-list with that subject's data.
#
#This function fits, for each subject in dlist, a logistic curve to
#their test 1 and test 2 performance and stores the parameters, including
#slope, intercept, and boundary, in an output matrix.
#
#dlist is the data list containing subject data
#sjs us a list of subjects to include in the analysis.

if(is.na(sjs)){                #if sjs is not specified, include all sjs
	nitems<-length(dlist)  # and set nitems to the number of subjects
	sjs <- 1:nitems}
else nitems<-length(sjs)

t1 <- matrix(0, nitems,2)	#create two temporary matrices to hold
t2<-t1				#test 1 and test 2 paramter estimates

#create temporary matrix to hold other data
cond<-matrix(c("E","E","E"), nitems, 3, byrow=T)

#Loop over subjects to get logistic parameters estimates for
#test 1 and test 2
for(i1 in c(1:nitems)){
	print(i1)
	sdat <- dlist[[sjs[i1]]] #pull out data for current subject
	tmod1<- glm(Acc~Pic, data = sdat[[2]], family="binomial") 	#fit test 1 model
	tmod2<- glm(Acc~Pic, data = sdat[[3]], family="binomial") 	#fit test 2 model
	t1[i1,]<-tmod1$coefficients 					#store test 1 coefficients
	t2[i1,]<-tmod2$coefficients					#store test 2 coefficients
	cond[i1,]<-as.matrix((sdat[[1]])[1,c(5,6,3)])			#pull out other info about this sj and condition
	}								#and store in cond matrix

b1<- -1 * t1[,1]/t1[,2]		#estimate boundary for test 1
b2<- -1 * t2[,1]/t2[,2]		#estimate boundary for test 2

cond<-as.data.frame(cond)	#convert cond matrix to data-frame object

out <- cond

out<-as.data.frame(cbind(cond,t1,b1,t2,b2)) #glue condition, t1, and t2 matrices together in data frame
names(out)<-c("axlab","farsource","sno","t1int","t1slope","t1bound","t2int","t2slope","t2bound") #name columns

bshift <- b2 - b1		#compute shift in boundary
closepos <- bshift		#copy bshift to midshift

#Flip direction for people in far-right group
#so positive numbers mean shift toward close source
#and away from far source
closepos[out$farsource=="R"] <- closepos[out$farsource=="R"] * -1

out<-cbind(out, bshift, closepos) #glue boundary shift data to output dataframe

Zclosepos <- (out$closepos - mean(out$closepos, na.rm=T))/sqrt(var(out$closepos, na.rm=T))  #compute Zscore for closepos across all conditions

#Compute Zscore for midshift separately for each boundary condition
#Zmsbycond <- rep(0, times = nitems) #make zero vector to hold data
#for(i1 in levels(out$bounds)){
#        mscond <- out$midshift[out$bounds==i1] #pull out data for current condition#
#	Zmsbycond[out$bounds == i1] <- (mscond - mean(mscond))/sqrt(var(mscond))  #compute zscores for current condition
#       }
out<-cbind(out, Zclosepos) #glue Zscores onto ouput data frame
out #output result
}


#!/bin/Rscript
library("R.utils")
library("dplyr")
library("plyr")
library("ggplot2")
library("dplyr")
library("broom")
library("ggpubr")
library("Amelia")
library("mlbench")
library("corrplot")
library('ANN2')
library('randomForest')

df <- read.csv("./data/weatherAUS.csv", header = TRUE, sep = ",", fill = TRUE)

n <- length(df[,1])
index <- sample(1:n,n,replace=FALSE)
df <- df[index,]

df[1:10,]

df[, "Date"] <- as.Date(df[, "Date"])
df[, "Location"] <- as.factor(df[, "Location"])
df[, "WindGustDir"] <- as.factor(df[, "WindGustDir"])
df[, "WindDir9am"] <- as.factor(df[, "WindDir9am"])
df[, "WindDir3pm"] <- as.factor(df[, "WindDir3pm"])
df[, "RainToday"] <- as.factor(df[, "RainToday"])
df[, "RainTomorrow"] <- as.factor(df [, "RainTomorrow"])
df["Cloud9am"][df["Cloud9am"] == 9] <- 8
df["Cloud3pm"][df["Cloud3pm"] == 9] <- 8

# # Deskriptive Analyse

parameters <- names(select_if(df, is.numeric))

for (x in parameters) {
  printf("Mean(%s): %f\n", x, mean(df[, x], na.rm = TRUE))
  printf("Median(%s): %f\n", x, median(df[, x], na.rm = TRUE))
  printf("Standard deviation(%s): %f\n\n", x, sd(df[, x], na.rm = TRUE))
}

missmap(df, col=c("blue", "red"), legend=FALSE)

correlations <- cor(select_if(df[,1:23],is.numeric), use="pairwise.complete.obs")
corrplot(correlations, method="circle")

parameters <- names(select_if(df,is.numeric))

dfmin <- subset(df, !is.na(df$RainToday) & !is.na(df$RainTomorrow))

for (x in parameters) {
  dfmin[x][is.na(dfmin[x])] <- mean(dfmin[, x], na.rm = TRUE)
}

levels(dfmin$WindGustDir) <- c(levels(dfmin$WindGustDir), "NOWIND")
levels(dfmin$WindDir9am) <- c(levels(dfmin$WindDir9am), "NOWIND")
levels(dfmin$WindDir3pm) <- c(levels(dfmin$WindDir3pm), "NOWIND")

dfmin$WindGustDir[is.na(dfmin[,"WindGustDir"])] <- "NOWIND"
dfmin$WindDir9am[is.na(dfmin[,"WindDir9am"])] <- "NOWIND"
dfmin$WindDir3pm[is.na(dfmin[,"WindDir3pm"])] <- "NOWIND"

summary(dfmin)
dfmin$WindDir3pm

missmap(dfmin, col=c("blue", "red"), legend=FALSE)

correlations <- cor(select_if(dfmin[,1:23],is.numeric), use="pairwise.complete.obs")
corrplot(correlations, method="circle")

correlations <- cor(select_if(df[,1:23],is.numeric), use="pairwise.complete.obs")
corrplot(correlations, method="circle")

#Maschinelles Lernen versch. Verfahren

### Daten splitten in Test- und Trainingsdatensätze

## 75% of the sample size
smp_size <- floor(0.95 * nrow(dfmin))  ## set the seed to make your partition reproducible
set.seed(123)
train_ind <- sample(seq_len(nrow(dfmin)), size = smp_size)
train <- dfmin[train_ind, ]
test <- dfmin[-train_ind, ]

train[train$RainTomorrow %in% c("NaN", "NA", "Inf"), ]
summary(train)

### Lineare Regression

# model <- glm(RainTomorrow~Date+Location+MinTemp+MaxTemp+Rainfall+Evaporation+Sunshine+WindGustDir+WindGustSpeed+WindDir9am+WindDir3pm+WindSpeed9am+WindSpeed3pm+Humidity9am+Humidity3pm+Pressure9am+Pressure3pm+Cloud9am+Cloud3pm+Temp9am+Temp3pm+RainToday, data = train, family = binomial)
# print(model)
#
# summary(model)
#
# glm.probs <- predict(model, newdata = test, type = "response")
# glm.probs[1:5]
#
# glm.pred <- ifelse(glm.probs > 0.5, "Yes", "No")
#
# test.RainTomorrow = test$RainTomorrow
# table(glm.pred,test.RainTomorrow)
#
# mean(glm.pred == test.RainTomorrow)

### Neuronales Netz

x_names = c("Date",
            "Location",
            "MinTemp",
            "MaxTemp",
            "Rainfall",
            "Evaporation",
            "Sunshine",
            "WindGustDir",
            "WindGustSpeed",
            "WindDir9am",
            "WindDir3pm",
            "WindSpeed9am",
            "WindSpeed3pm",
            "Humidity9am",
            "Humidity3pm",
            "Pressure9am",
            "Pressure3pm",
            "Cloud9am",
            "Cloud3pm",
            "Temp9am",
            "Temp3pm",
            "RainToday")
y_names = c("RainTomorrow")

neural_net <- function(
  data,
  x_rel,
  y_rel,
  hiddenlayers = c(4, 3),
  regression = FALSE,
  losstype = "log",
  learnrates = 1e-04,
  nepochs = 1,
  verbose = TRUE
) {
  x <- model.matrix(
    gen_model(x_rel, y_rel),
    c(data[x_rel], data[y_rel])
  )
  x <- x[, -1]   # entferne den Intercept
  y <- as.factor(data[, y_rel])
  model <- neuralnetwork(
    x,
    y,
    hidden.layers = hiddenlayers,
    regression = regression,
    loss.type = losstype,
    learn.rates = learnrates,
    n.epochs = nepochs,
    verbose = verbose
  )
  return(model)
}

prep <- function(data, x_rel, y_rel) {
  x <- model.matrix(
    gen_model(x_rel, y_rel),
    c(data[x_rel], data[y_rel])
  )
  x <- x[, -1]   # entferne den Intercept
  y <- as.factor(data[, y_rel])
  return(c(x = x, y = y))
}

gen_model <- function(params, y) {
  return(as.formula(paste(paste(y, " ~ "), paste(params, collapse = " + "))))
}

# nn1 <- neural_net(train, x_names, y_names, hiddenlayers = c(2))
# nn1
# p <- prep(test, x_names, y_names)
# prognosen <- predict(nn1, p["x"])$predictions
# mean(abs(prognosen - p["y"]))

model1 <- randomForest(RainTomorrow ~ ., data = test, importance = TRUE)
plot(model1)


#install.packages("quantmod")
#install.packages("dplyr")
#install.packages("IntroCompFinR")
#install.packages("PerformanceAnalytics")
#install.packages("readxl")
#install.packages("tseries")
library(quantmod)
library(readxl)
library(dplyr)
# The IntroCompFinR package has functions for portfolio optimization
library(IntroCompFinR)
# The PerformanceAnalytics package has several functions to evaluate, manage
# and optimize portfolios
library(PerformanceAnalytics)
# The tseries package has functions related to time series data management
library(tseries)
rm(list = ls())
#hay que cambiar esto para que funcione
setwd("C:/Users/joaqu/Documents/Codigo/FinancesR/Workshops")
input.df = read_excel("InputEx1.xlsx",sheet="Portfoliosets")
sheet.list<-input.df$sheet

# Download the financial information from the web
for (j in 1:length(input.df$portfolio)){
  input2.df=read_excel("InputEx1.xlsx",sheet=sheet.list[j])
  tickers.list=input2.df$ticker
  getSymbols(tickers.list,
             from = "2016-01-01", to = Sys.Date()-1,
             periodicity = "monthly",
             src = "yahoo")
  prices.zoo=xts()
  for (i in 1:length(tickers.list)){
    prices.zoo=merge(prices.zoo,get(tickers.list[i]))
  }
  returns.zoo=diff(log(prices.zoo))
  returns.df <- as.data.frame(returns.zoo, na.remove = TRUE) %>%
    na.omit() %>%
    select(contains("Adjusted"))
  covm=var(returns.df)
  ER <-exp(apply(returns.df,2,mean))-1
  W=as.matrix(input2.df[,2:length(input2.df)])
  ERP <- t(W) %*% ER
  VARP <-t(W)%*% covm %*% W
  VARP=diag(VARP)
  RISKP <-sqrt(VARP)
  plot(RISKP,ERP, main="Portolio Risk vs Return")
  #ERP
  print(ERP)
  #RISKP
  print(RISKP)
  gmvportws = globalMin.portfolio(ER, covm,shorts=input.df$short[j])
  #GVM
  print(gmvportws)

  #hpr
  for (i in 1:length(returns.df)){
    print(exp(sum(returns.df[i]))-1)
  }
}


# Support Vector regression for machine learning.
#
# Support Vector Machine can also be used as a regression method, maintaining all
# the main features that characterize the algorithm (maximal margin). The Support
# Vector Regression (SVR) uses the same principles as the SVM for classification,
# with only a few minor differences. First of all, because output is a real
# number it becomes very difficult to predict the information at hand, which has
# infinite possibilities. In the case of regression, a margin of tolerance is set
# in approximation to the SVM which would have already requested from the
# problem. But besides this fact, there is also a more complicated reason, the
# algorithm is more complicated therefore to be taken in consideration. However,
# the main idea is always the same: to minimize error, individualizing the
# hyperplane which maximizes the margin, keeping in mind that part of the error
# is tolerated.

# Importing the data set
dataset = read.csv('Position_Salaries.csv')
dataset = dataset[2:3]

# Splitting the Dataset into a Training set and a Test set
# install.packages('caTools')
# library(caTools)
# set.seed(123) # choose random number, only same number for debugging
# split = sample.split(dataset$Salary, SplitRatio = 0.8)
# training_set = subset(dataset, split==TRUE)
# test_set = subset(dataset, split==FALSE)

# Feature Scaling
# training_set = scale(training_set)
# test_set = scale(test_set)

# Fit SVR to the dataset
# install.packages('e1071')
# library(e1071)
regressor = svm(formula = dataset$Salary ~ .,
                data = dataset,
                type = 'eps-regression')

# Predict a new result with SVR model
y_pred = predict(regressor, newdata = data.frame(Level = 6.5))

# Visualize graphic result of the SVR model
# install.packages('ggplot2')
# library(ggplot2)
ggplot() +
  geom_point(aes(x = dataset$Level, y = dataset$Salary),
             colour='red') +
  geom_line(aes(x = dataset$Level, y = predict(regressor, newdata = dataset)),
            colour='blue') +
  ggtitle('Truth or Bluff (SVR)') +
  xlab('Level') + ylab('Salary')


library(ggplot2)

setwd("/home/lucas/git/linefollower-arduino/")

data = read.csv("data/pwm_angle.csv")

lm(pwm ~ degree, data)
lm(degree ~ pwm, data)

pwdFromDegree <- function(degree) 27.6527 + 0.5251 * degree
degreeFromPwm <- function(pwm) -46.831 + 1.856 * pwm

data$f <- pwdFromDegree(data$degree)

ggplot(data) + geom_line(aes(degree, pwm)) +
               geom_line(aes(degree, f))

data$g <- degreeFromPwm(data$pwm)

ggplot(data) + geom_line(aes(pwm, degree)) +
  geom_line(aes(pwm, g))


# ------------------------------------------------------------------------------
# Description:  Script to process soil texture data from Grassland Connectivity
#               study in Walnut Gulch Experimental Watershed (2018). Texture
#               was determined using hydrometer method.
# Date:         1/6/21
# Author:       Justin Johnson
# ------------------------------------------------------------------------------
# Install and load packages
pkgs <- c('tidyverse','car')

check <- sapply(pkgs,require,warn.conflicts = TRUE,character.only = TRUE)
if(any(!check)){
  pkgs.missing <- pkgs[!check]
  install.packages(pkgs.missing)
  check <- sapply(pkgs.missing,require,warn.conflicts = TRUE,character.only = TRUE)
}

# ------------------------------------------------------------------------------
# Inputs
filename <- "Data/rg47_finescale_soil_texture.csv"

# ------------------------------------------------------------------------------
# Read in soil texture data
fine_texture <- read_csv(filename, col_types = "fffffnnnf")

# Add a column for all four combinations of microsites and treatments
fine_texture <- fine_texture %>%
  unite(micro, treatment, microsite, remove = FALSE) %>%
  mutate(micro = factor(micro))

# ------------------------------------------------------------------------------
# Sand analysis
# ------------------------------------------------------------------------------
# Create linear model
sand_model <- aov(lm(sand.pct ~ micro, data = fine_texture))

# View diagnostic plots
plot(sand_model)

# Test for homogeneity of variance (Levene's Test)
leveneTest(sand_model)

# Test for normality of data
aov_residuals <- residuals(object = sand_model)
shapiro.test(aov_residuals)

# Assumptions of normality and homogeneity of variance are met.
# Perform one-way ANOVA.
summary(sand_model)

# All microsites are statistically comparable

# ------------------------------------------------------------------------------
# Silt analysis
# ------------------------------------------------------------------------------
# Assuming normality and homogeneity of variance based on sand results

# Create linear model
silt_model <- aov(lm(silt.pct ~ micro, data = fine_texture))

# Perform one-way ANOVA.
summary(silt_model)

# All microsites are statistically comparable

# ------------------------------------------------------------------------------
# Clay analysis
# ------------------------------------------------------------------------------
# Assuming normality and homogeneity of variance based on sand results

# Create linear model
clay_model <- aov(lm(clay.pct ~ micro, data = fine_texture))

# Perform one-way ANOVA.
summary(clay_model)

# All microsites are statistically comparable

# ------------------------------------------------------------------------------
# Summarize data
# ------------------------------------------------------------------------------
texture_summary <- fine_texture %>%
  summarize(sand = mean(sand.pct),
            silt = mean(silt.pct),
            clay = mean(clay.pct))


##
## Reciprocity in the three net-maps and gift networks
##
source("init if necessary.r")
library(dplyr)
library(igraph)
library(ggplot2)

flog.info("Started social network analysis - reciprocity")

net_names = c("Advice", "Help", "Sharing", "Gifts")

####################################################
## Observed reciprocity
##
obs.recip = data.frame(Network = net_names,
                       reciprocity = c(reciprocity(g.advice),
                                       reciprocity(g.help),
                                       reciprocity(g.sharing),
                                       reciprocity(g.gifts)),
                       assortment  = c(assortativity.nominal(g.advice, types=V(g.advice)$SiidaID, directed=T),
                                       assortativity.nominal(g.help, types=V(g.help)$SiidaID, directed=T),
                                       assortativity.nominal(g.sharing, types=V(g.sharing)$SiidaID, directed=T),
                                       assortativity.nominal(g.gifts, types=V(g.gifts)$SiidaID, directed=T)))

####################################################
## simulate random behaviour in networks
##
neutral.network.sim = function(n.egos, n.alters, n.ties=3, n.sims=1000, n.groups = 15) {
  require(igraph)

  ## debug ###
  # n.egos = 53; n.alters = 120; n.ties=3; n.sims=1000
  ###

  blank.matrix = matrix(0, n.alters - n.egos, n.alters)  # blank matrix to tag onto end (since iGraph needs symmetrical matrix to generate graphs)
  # set up dataframe for results
  recip = data.frame(i=integer(0), reciprocity=numeric(0), reciprocity.er=numeric(0), assortment=numeric(0))

  # assign people to siidas randomly
  siida_members = sample(1:n.groups, n.alters, replace=T)

  for (i in 1:n.sims) {
    gifts.rnd = matrix(0, n.egos, n.alters)

    # each row (giver) can give at least one, up to `n.ties` gifts/helps
    for (j in 1:n.egos) {
      #recipients = sample(1:n.alters, n.ties, replace=F)  # choose `n.ties` number of recipients
      recipients = sample(1:n.alters, round(runif(1, min=1, max=n.ties), 0), replace=F)  # choose between 1 and `n.ties` number of recipients
      gifts.rnd[j, recipients] = 1  # give them gifts
    }
    # make symmetrical matrix
    gifts.rnd = rbind(gifts.rnd, blank.matrix)
    # generate the graph from adj matrix
    g.tmp = graph.adjacency(gifts.rnd, mode="directed", diag=F)

    # for assortativity, get nodes and in-degrees
    in.deg = degree(g.tmp, mode="in")

    # also make an erdos-renyi random graph and calculate its reciprocity
    g.rnd = sample_gnm(n=n.alters, m=n.ties, directed=T)

    # save results
    recip = rbind(recip, c(i, reciprocity(g.tmp), reciprocity(g.rnd), assortativity.nominal(g.tmp, types=siida_members, directed=T)))
  }

  names(recip) = c("i", "reciprocity", "reciprocity.rnd", "assortment")
  return(recip)
}

##################################################
## Simulate networks for each net-map and gifts
##
## gifts
##
n.gift.givers = length(unique(gifts$Ego))  # no. people who played gift game
n.recipients = nrow(herders)  # no. potential recipients
n.gifts = gifts %>% group_by(Ego) %>% summarise(n.gifts = n())
n.gifts = max(n.gifts$n.gifts)
n.gifts = ifelse(n.gifts == 0, 1, n.gifts)  # make sure they give at least one gift

# sim
sim.gifts = neutral.network.sim(n.gift.givers, n.recipients, n.gifts)
sim.gifts$Network = "Gifts"

##
## advice
##
n.ego   = length(unique(net.maps.advice$Ego))
n.alter = length(unique(net.maps.advice$Alter))
n.ties  = net.maps.advice %>% group_by(Ego) %>% summarise(n.ties =length(Ego)) %>% summarise(max(n.ties)) %>% unlist(.)
n.ties  = ifelse(n.ties == 0, 1, n.ties)  # make sure they have at least one tie
# sim
sim.advice = neutral.network.sim(n.ego, n.alter, n.ties)
sim.advice$Network = "Advice"

##
## help
##
n.ego   = length(unique(net.maps.help$Ego))
n.alter = length(unique(net.maps.help$Alter))
n.ties  = net.maps.help %>% group_by(Ego) %>% summarise(n.ties =length(Ego)) %>% summarise(max(n.ties)) %>% unlist(.)
n.ties  = ifelse(n.ties == 0, 1, n.ties)  # make sure they have at least one tie
# sim
sim.help = neutral.network.sim(n.ego, n.alter, n.ties)
sim.help$Network = "Help"

##
## sharing
##
n.ego   = length(unique(net.maps.sharing$Ego))
n.alter = length(unique(net.maps.sharing$Alter))
n.ties  = net.maps.sharing %>% group_by(Ego) %>% summarise(n.ties =length(Ego)) %>% summarise(max(n.ties)) %>% unlist(.)
n.ties  = ifelse(n.ties == 0, 1, n.ties)  # make sure they have at least one tie
# sim
sim.sharing = neutral.network.sim(n.ego, n.alter, n.ties)
sim.sharing$Network = "Sharing"

# bosh them all together
sim.nets = dplyr::bind_rows(sim.advice, sim.help, sim.sharing, sim.gifts)

sim.nets$Network = factor(sim.nets$Network, levels=net_names)

############################################################
## Plot reciprocities
##
plt.recip = ggplot(sim.nets, aes(x=factor(Network), y=reciprocity)) +
  #facet_wrap(~Measure, scales="free", ncol=2) +
  geom_boxplot() +
  geom_point(data=obs.recip, aes(x=factor(Network), y=reciprocity), fill=saami_lightred, colour=saami_red, shape=23, size=3) +

  geom_blank(data=obs.recip) +
  #ylim(c(0, round(max(obs.recip$Value), 1))) +  # extend y-axis so observed reciprocities will appear
  ylab("Simulated/observed reciprocity") +
  xlab("Network") +
  ggtitle("a") +
  common_theme +
  theme(plot.title = element_text(face="bold"))

##
## ... and assortativities
##
plt.assort = ggplot(sim.nets, aes(x=factor(Network), y=assortment)) +
  #facet_wrap(~Measure, scales="free", ncol=2) +
  geom_boxplot() +
  geom_point(data=obs.recip, aes(x=factor(Network), y=assortment), fill=saami_lightred, colour=saami_red, shape=23, size=3) +

  geom_blank(data=obs.recip) +
  #ylim(c(0, round(max(obs.recip$Value), 1))) +  # extend y-axis so observed reciprocities will appear
  ylab("") +  # don't need y label because displaying it next to reciprocity figure, which has one
  xlab("Network") +
  ggtitle("b") +
  common_theme +
  theme(plot.title = element_text(face="bold"))

png(filename=file.path(plots.dir, "network stats - reciprocity and assortment.png"), height=10, width=20, units="cm", res=300)
  gridExtra::grid.arrange(plt.recip, plt.assort, ncol=2)
dev.off()

pdf(file.path(plots.dir, "network stats - reciprocity and assortment.pdf"), height=5, width=10)
  gridExtra::grid.arrange(plt.recip, plt.assort, ncol=2)
dev.off()

flog.info("Finished society network analysis - reciprocity")


#!/usr/bin/env Rscript

#Andrew Burt - a.burt@ucl.ac.uk

#suppressMessages(library(lmtest))
#suppressMessages(library(nortest))

fitOLS <- function(data,func)
{
	return(lm(func,data))
}

yhatOLSLog <- function(data,model)
{
	return(predict.lm(model,data))
}

yhatOLSArithmetic <- function(data,model,corrected=TRUE)
{
	if(corrected == FALSE) return(exp(predict.lm(model,data)))
	else return(exp(summary(model)$sigma**2/2) * exp(predict.lm(model,data)))
}

rainbow_test <- function(model)
{
	print(raintest(model))
}

studentised_breusch_pagan_test <- function(data,func,model)
{
	print(bptest(model,func,data=data))
}

studentised_white_test <- function(data,func,model)
{
	funcw <- toString(c(func))
	params <- strsplit(strsplit((toString(c(func))),"~")[[1]][2],"+",fixed=TRUE)
	for(i in 1:length(params[[1]]))
	{
		funcw <- paste(funcw," + I(",gsub(" ","",params[[1]][i], fixed = TRUE),"**2)",sep="")
	}
	print(bptest(model,formula(funcw),data=data))
}

#anderson_darling_test <- function(model)
#{
#	print(ad.test(resid(model)))
#}

shapiro_wilk_test <- function(model)
{
	print(shapiro.test(resid(model)))
}


##' Plot prevalence with confidence intervals as measured in national mass-testing in Slovakia
##'
##' @return plot of prevalence with exact binomial confidence intervals
##' @importFrom binom binom.confint
##' @importFrom dplyr select mutate
##' @importFrom ggplot2 ggplot geom_linerange geom_point geom_hline xlab ylab coord_flip theme_classic scale_colour_manual
##' @importFrom forcats fct_reorder
prevalence <- function() {
  ms.tst %>%
    mutate(round_2 =
             if_else(is.na(attendance_3), "Not included", "Included")) %>%
    select(county, round_2, attendance_2, positive_2) %>%
    mutate(prev = positive_2 / attendance_2,
           prev.lo = binom.confint(positive_2, attendance_2,
                                   methods = "exact")$lower,
           prev.hi = binom.confint(positive_2, attendance_2,
                                   methods = "exact")$upper) %>%
    ggplot(aes(x = fct_reorder(county, prev),
               y = prev, ymin = prev.lo, ymax = prev.hi, colour = round_2)) +
    geom_linerange() +
    geom_point() +
    geom_hline(yintercept = 0.007, lty = "dashed") +
    xlab("") +
    ylab("Proportion of tests positive\nin the first round of mass testing") +
    coord_flip() +
    theme_classic() +
    scale_colour_manual("Round 2", values = c("red", "black"))
}


#' Perform SVD confounder analysis.
#'
#' Perform SVD confounder analysis and association tests between the Principal
#' Components of the given input values and the phenotype data.
#'
#' This function performs a series of association tests between the Principal
#' Components of the input values and the provided phenotype data. Previously,
#' it centers and scales the data, something that might be useful when the
#' variables are measured in different units.
#'
#' If a RGChannelSet is given, it can also compute the association with the
#' control probes. This implementation can use two different methods for testing
#' (Linear models and Kruskal-Wallis).
#'
#' The number of meaningful components is computed using the function
#' \code{EstDimRMT} from the package \code{isva}.
#'
#' @param values A matrix of numerical values. Rows represent
#'   variables and columns samples.
#' @param pdata A data.frame containing the phenotype data for the samples.
#' @param center A logical value indicating whether the variables should be
#'   shifted to be zero centered. Alternately, a vector of length equal the
#'   number of columns of x can be supplied. The value is passed to scale.
#' @param scale A logical value indicating whether the variables should be
#'   scaled to have unit variance before the analysis takes place. The default
#'   is FALSE for consistency with S, but in general scaling is advisable.
#'   Alternatively, a vector of length equal the number of columns of x can be
#'   supplied. The value is passed to scale. Use when the variables are in
#'   arbitrary units of measurement.
#' @param rgset If not NULL, compute association with control probes data
#'   contained in the provided RGChannelSet.
#' @param method Method used for computing p-values.
#' @return A list containing the proportion of variance explained by the
#'   principal components (variance_explained) and a data.frame representing the
#'   results from the association analysis (significance).
#'
#' @export
svd_analysis = function(
  values,
  pdata,
  center = TRUE,
  scale = FALSE,
  rgset = NULL,
  method = c('lm', 'kruskal')) {

  method = match.arg(method)
  scaled_values = scale(t(values), center = center, scale = scale)

  sv_decomp = svd(scaled_values)
  var_explained = sv_decomp[['d']] ^ 2 / sum(sv_decomp[['d']] ^ 2)
  component_names = paste0('PC-', 1:length(var_explained))
  component_names = factor(component_names, levels = component_names)

  variance_explained_data = data.frame(
    PC = component_names,
    Var = var_explained
  )

  if (nrow(pdata) != nrow(scaled_values)) {
    stop(paste('The num of pdata row elements must be equal',
               'to row elements of [v] or [u].',
               'Actual number of row elements pdata:', nrow(pdata)))
  }

  significance_data = compute_significance_data(sv_decomp[['u']], pdata,
                                                component_names,
                                                method = method)

  sig_data_rgset = NULL

  if (!is.null(rgset)) {
    data_control_values = get_control_variables(rgset)
    var_names = colnames(data_control_values)
    names(var_names) = var_names
    sig_data_rgset = compute_significance_data_var_names(sv_decomp[['u']],
                                                         data_control_values,
                                                         component_names,
                                                         var_names)
    significance_data = rbind(significance_data, sig_data_rgset)

    significance_data[['Variable']] = factor(
      significance_data[['Variable']],
      levels = unique(significance_data[['Variable']])
      )
  }

  dim_pca = isva::EstDimRMT(t(scaled_values), plot = FALSE)[['dim']]

  result = list(
    variance_explained = variance_explained_data,
    center = center,
    scale = scale,
    method = method,
    significance = significance_data,
    significance_control = sig_data_rgset,
    limit_significant_PC = dim_pca
  )

  class(result) = append(class(result), 'SVDAnalysis')
  return(result)
}


####################################################################
## Double Seasonal Holt Winters method as per Taylor (2003)
## Periods must be nested.
## y can be an msts object, or periods can be passed explicitly.
####################################################################

#' Double-Seasonal Holt-Winters Forecasting
#'
#' Returns forecasts using Taylor's (2003) Double-Seasonal Holt-Winters method.
#'
#' Taylor's (2003) double-seasonal Holt-Winters method uses additive trend and
#' multiplicative seasonality, where there are two seasonal components which
#' are multiplied together. For example, with a series of half-hourly data, one
#' would set \code{period1=48} for the daily period and \code{period2=336} for
#' the weekly period. The smoothing parameter notation used here is different
#' from that in Taylor (2003); instead it matches that used in Hyndman et al
#' (2008) and that used for the \code{\link{ets}} function.
#'
#' @param y Either an \code{\link{msts}} object with two seasonal periods or a
#' numeric vector.
#' @param period1 Period of the shorter seasonal period. Only used if \code{y}
#' is not an \code{\link{msts}} object.
#' @param period2 Period of the longer seasonal period.  Only used if \code{y}
#' is not an \code{\link{msts}} object.
#' @param h Number of periods for forecasting.
#' @param alpha Smoothing parameter for the level. If \code{NULL}, the
#' parameter is estimated using least squares.
#' @param beta Smoothing parameter for the slope. If \code{NULL}, the parameter
#' is estimated using least squares.
#' @param gamma Smoothing parameter for the first seasonal period. If
#' \code{NULL}, the parameter is estimated using least squares.
#' @param omega Smoothing parameter for the second seasonal period. If
#' \code{NULL}, the parameter is estimated using least squares.
#' @param phi Autoregressive parameter. If \code{NULL}, the parameter is
#' estimated using least squares.
#' @param lambda Box-Cox transformation parameter. Ignored if \code{NULL}.
#' Otherwise, data transformed before model is estimated.
#' @param biasadj Use adjusted back-transformed mean for Box-Cox
#' transformations. If TRUE, point forecasts and fitted values are mean
#' forecast. Otherwise, these points can be considered the median of the
#' forecast densities. By default, the value is taken from what was used when
#' fitting the model.
#' @param armethod If TRUE, the forecasts are adjusted using an AR(1) model for
#' the errors.
#' @param model If it's specified, an existing model is applied to a new data
#' set.
#' @return An object of class "\code{forecast}" which is a list that includes the
#' following elements:
#'   \item{model}{A list containing information about the fitted model}
#'   \item{method}{The name of the forecasting method as a character string}
#'   \item{mean}{Point forecasts as a time series}
#'   \item{x}{The original time series.}
#'   \item{residuals}{Residuals from the fitted model. That is x minus fitted values.}
#'   \item{fitted}{Fitted values (one-step forecasts)}
#'
#' The function \code{summary} is used to obtain and print a summary of the
#' results, while the function \code{plot} produces a plot of the forecasts.
#'
#' The generic accessor functions \code{fitted.values} and \code{residuals}
#' extract useful features of the value returned by \code{dshw}.
#'
#' @author Rob J Hyndman
#' @seealso \code{\link[stats]{HoltWinters}}, \code{\link{ets}}.
#' @references Taylor, J.W. (2003) Short-term electricity demand forecasting
#' using double seasonal exponential smoothing. \emph{Journal of the
#' Operational Research Society}, \bold{54}, 799-805.
#'
#' Hyndman, R.J., Koehler, A.B., Ord, J.K., and Snyder, R.D. (2008)
#' \emph{Forecasting with exponential smoothing: the state space approach},
#' Springer-Verlag. \url{http://www.exponentialsmoothing.net}.
#' @keywords ts
#' @examples
#'
#' \dontrun{
#' fcast <- dshw(taylor)
#' plot(fcast)
#'
#' t <- seq(0,5,by=1/20)
#' x <- exp(sin(2*pi*t) + cos(2*pi*t*4) + rnorm(length(t),0,.1))
#' fit <- dshw(x,20,5)
#' plot(fit)
#' }
#'
#' @export
dshw <- function(y, period1=NULL, period2=NULL, h=2*max(period1,period2),
  alpha=NULL, beta=NULL, gamma=NULL, omega=NULL, phi=NULL, lambda=NULL, biasadj=FALSE,
  armethod=TRUE, model = NULL)
{
  if(min(y,na.rm=TRUE) <= 0)
    stop("dshw not suitable when data contain zeros or negative numbers")
  seriesname <- deparse(substitute(y))
  if (!is.null(model) && model$method == "DSHW") {
    period1 <- model$period1
    period2 <- model$period2
  } else if(any(class(y) == "msts") & (length(attr(y, "msts")) == 2)) {
	  period1 <- as.integer(sort(attr(y, "msts"))[1])
	  period2 <- as.integer(sort(attr(y, "msts"))[2])
  } else if(is.null(period1) | is.null(period2)) {
	  stop("Error in dshw(): y must either be an msts object with two seasonal periods OR the seasonal periods should be specified with period1= and period2=")
  } else {
    if(period1 > period2)
    {
      tmp <- period2
      period2 <- period1
      period1 <- tmp
    }
  }
  if(any(class(y) != "msts"))
    y <- msts(y, c(period1, period2))

  if(length(y) < 2*max(period2))
    stop("Insufficient data to estimate model")

  if(!armethod)
    phi <- 0

  if(period1 < 1 | period1 == period2)
    stop("Inappropriate periods")
  ratio <- period2/period1
  if(ratio-trunc(ratio) > 1e-10)
    stop("Seasonal periods are not nested")

  if (!is.null(model)) {
    lambda <- model$model$lambda
  }

  if (!is.null(lambda))
  {
    origy <- y
    y <- BoxCox(y, lambda)
  }

  if (!is.null(model)) {
    pars <- model$model
    alpha <- pars$alpha
    beta <- pars$beta
    gamma <- pars$gamma
    omega <- pars$omega
    phi <- pars$phi
  } else {
    pars <- rep(NA,5)
    if(!is.null(alpha))
      pars[1] <- alpha
    if(!is.null(beta))
      pars[2] <- beta
    if(!is.null(gamma))
      pars[3] <- gamma
    if(!is.null(omega))
      pars[4] <- omega
    if(!is.null(phi))
      pars[5] <- phi
  }

  # Estimate parameters
  if(sum(is.na(pars)) > 0)
  {
    pars <- par_dshw(y,period1,period2,pars)
    alpha <- pars[1]
    beta <- pars[2]
    gamma <- pars[3]
    omega <- pars[4]
    phi <- pars[5]
  }

  ## Allocate space
  n <- length(y)
  yhat <- numeric(n)

  ## Starting values
  I <- seasindex(y,period1)
  wstart <- seasindex(y,period2)
  wstart <- wstart / rep(I,ratio)
  w <- wstart
  x <- c(0,diff(y[1:period2]))
  t <- t.start <- mean(((y[1:period2]- y[(period2+1):(2*period2)])/period2 ) + x )/2
  s <- s.start <- (mean(y[1:(2*period2)])-(period2+0.5)*t)

  ## In-sample fit
  for(i in 1: n)
  {
    yhat[i] <- (s+t) * I[i]*w[i]
    snew <- alpha*(y[i]/(I[i]*w[i]))+(1-alpha)*(s+t)
    tnew <- beta*(snew-s)+(1-beta)*t
    I[i+period1] <- gamma*(y[i]/(snew*w[i])) + (1-gamma)*I[i]
    w[i+period2] <- omega*(y[i]/(snew*I[i])) + (1-omega)*w[i]
    s <- snew
    t <- tnew
  }

	# Forecasts
  fcast <- (s + (1:h)*t) * rep(I[n+(1:period1)],h/period1 + 1)[1:h] * rep(w[n+(1:period2)],h/period2 + 1)[1:h]
  fcast <- ts(fcast,frequency=frequency(y),start=tsp(y)[2]+1/tsp(y)[3])

  # Calculate MSE and MAPE
  yhat <- ts(yhat)
  tsp(yhat) <- tsp(y)
  yhat <- msts(yhat, c(period1, period2))
  e <- y - yhat
  e <- msts(e, c(period1, period2))
  if(armethod)
	{
		yhat <- yhat + phi * c(0,e[-n])
		e <- y - yhat
	  fcast <- fcast + phi^(1:h)*e[n]
	}
	mse <- mean(e^2)
	mape <- mean(abs(e)/y)*100

  end.y <- end(y)
  if(end.y[2] == frequency(y)) {
	  end.y[1] <- end.y[1]+1
	  end.y[2] <- 1
  } else {
	  end.y[2] <- end.y[2]+1
  }

  fcast <- msts(fcast, c(period1, period2))

  if(!is.null(lambda))
  {
    y <- origy
    fcast <- InvBoxCox(fcast, lambda, biasadj, var(e))
    attr(lambda, "biasadj") <- biasadj
    #Does this also need a biasadj backtransform?
    yhat <- InvBoxCox(yhat,lambda)
  }

  return(structure(list(mean=fcast,method="DSHW",x=y,residuals=e,fitted=yhat,series=seriesname,
              model=list(mape=mape,mse=mse,alpha=alpha,beta=beta, gamma=gamma,omega=omega,phi=phi,
                         lambda = lambda, l0=s.start,b0=t.start,s10=wstart,s20=I), period1 = period1,
                         period2 = period2),class="forecast"))

}

### Double Seasonal Holt-Winters smoothing parameter optimization

par_dshw <- function(y, period1, period2, pars)
{
  start <- c(0.1,0.01,0.001,0.001,0.0)[is.na(pars)]
  out <- optim(start, dshw.mse, y=y, period1=period1, period2=period2, pars=pars)
  pars[is.na(pars)] <- out$par
  return(pars)
}

dshw.mse <- function(par, y, period1, period2, pars)
{
  pars[is.na(pars)] <- par
  if(max(pars) > 0.99 | min(pars) < 0 | pars[5] > .9)
    return(1e20)
  else
    return(dshw(y, period1, period2, h=1, pars[1], pars[2], pars[3], pars[4], pars[5], armethod=(abs(pars[5]) >1e-7))$model$mse)
}

### Calculating seasonal indexes
seasindex <- function(y,p)
{
  #require(zoo)
  n <- length(y)
  n2 <- 2*p
  shorty <- y[1:n2]
  average <- numeric(n)
  simplema <- zoo::rollmean.default(shorty, p)
  if (identical(p%%2,0)) # Even order
  {
    centeredma <- zoo::rollmean.default(simplema[1:(n2-p+1)],2)
    average[p/2 + 1:p] <- shorty[p/2 + 1:p]/centeredma[1:p]
    si <- average[c(p+(1:(p/2)),(1+p/2):p)]
  }
  else # Odd order
  {
    average[(p-1)/2 + 1:p] <- shorty[(p-1)/2 + 1:p]/simplema[1:p]
    si <- average[c(p+(1:((p-1)/2)),(1+(p-1)/2):p)]
  }
  return(si)
}


# 4. faza: Analiza podatkov

#LINEARNA REGRESIJA

#Linearen model za skupno število stanovanj s slabo kakovostjo v odvisnosti od leta

podatki <- stanovanjske_razmere %>% group_by(leto)  %>%
  summarize(stanovanja_skupno = sum(stevilo_stanovanj))
podatki$leto <- as.numeric(podatki$leto)
fit <- lm(stanovanja_skupno ~ leto , data=podatki)

graf <- ggplot(podatki, aes(x = leto, y = stanovanja_skupno)) +
  geom_point() + geom_smooth(method=lm, se=FALSE) +
  labs(x = "Leto" , y = "SKupno število stanovanj" , title = "Ponazoritev premice linearne regresije - \n skupno število stanovanj v odvisnosti od leta")

predict(fit, data.frame(leto =c(2021, 2022)))


rm(list=ls())
library(plyr)
library(tidyverse)
library(tidyr)
library(dplyr)
library(ggplot2)
library(ggpubr)

# set dataset

dataset <- "Streicher"

setwd(paste("/Users/ChatNoir/Projects/Squam/Graphs/",dataset, sep=''))

# Read in data
load(paste("/Users/ChatNoir/Projects/Squam/Graphs/",dataset,"/Calcs_",dataset,".RData", sep=''))

# Colors
color_S <- "orange"
color_TP <- "springgreen4"
color_AI <- "#2BB07FFF"
color_SA <- "#38598CFF"
color_SI <- "#C2DF23FF"

# Add column to name type of support
mLGL <- mutate(mLGL, supportType = case_when(TvS != 'a' ~ "dGLS"))
mLBF <- mutate(mLBF, supportType = case_when(TvS != 'a' ~ "BF"))

# Calculate percentile numbers
per <- seq(0,1,0.1)
x <- mLGL %>% summarise(TvS = list(enframe(quantile(TvS, probs=per)))) %>% unnest

# Set title and input data
title.g <- paste(dataset," - AI v SA",sep="")
cc.g <- color_AI
df.g <- mLGL
xval.g <- mLGL$AIvSA
xlablab.g <- 'dGLS'

datSum.g <- ddply(df.g,.(supportType),summarise,
                q1 = quantile(xval.g,0.1),
                q2 = quantile(xval.g,0.2),
                q3 = quantile(xval.g,0.3),
                q4 = quantile(xval.g,0.4),
                q5a = quantile(xval.g,0.49),
                q5 = quantile(xval.g,0.5),
                q5b = quantile(xval.g,0.51),
                q6 = quantile(xval.g,0.6),
                q7 = quantile(xval.g,0.7),
                q8 = quantile(xval.g,0.8),
                q9 = quantile(xval.g,0.9))
datSum.g$NameAlt <- 1:1
datSum.g
tics.g <- seq(-0.7,0.8,0.01) # Streicher

GL <- ggplot(datSum.g,aes(ymin = NameAlt - 0.2,ymax = NameAlt + 0.2)) +
  geom_rect(aes(xmin = q1,xmax = q9),fill = "white",colour = "black") +
  geom_rect(aes(xmin = q2,xmax = q8),fill = "lightblue",colour = "black") +
  geom_rect(aes(xmin = q3,xmax = q7),fill = "dodgerblue",colour = "black") +
  geom_rect(aes(xmin = q4,xmax = q6),fill = 'blue',colour = "black") +
  #geom_rect(aes(xmin = q5,xmax = q5),fill = 'midnightblue',colour = "black") +
  theme_classic() +
  theme(axis.line.y=element_blank(),
        axis.ticks.y=element_blank(),
        axis.text.y=element_blank(),
        plot.title = element_text(hjust = 0.5, size=16),
        axis.text = element_text(size=10, color="black"),
        text = element_text(size=14)) +
  labs(x=xlablab.g,y="") +
  coord_cartesian(xlim=tics.g) +
  scale_x_continuous(breaks = tics.g)

# Set title and input data
title <- paste(dataset," - Tox vs Sclero",sep="")
cc <- color_TP
df <- mLBF
xval <- mLBF$TvS
xlablab <- '2ln(BF)'

datSum <- ddply(df,.(supportType),summarise,
                q1 = quantile(xval,0.1),
                q2 = quantile(xval,0.2),
                q3 = quantile(xval,0.3),
                q4 = quantile(xval,0.4),
                q5a = quantile(xval,0.49),
                q5 = quantile(xval,0.5),
                q5b = quantile(xval,0.51),
                q6 = quantile(xval,0.6),
                q7 = quantile(xval,0.7),
                q8 = quantile(xval,0.8),
                q9 = quantile(xval,0.9))
datSum$NameAlt <- 1:1
datSum
tics <- seq(-10,27,5) # Streicher
BF <- ggplot(datSum,aes(ymin = NameAlt - 0.2,ymax = NameAlt + 0.2)) +
  geom_rect(aes(xmin = q1,xmax = q9),fill = "white",colour = "black") +
  geom_rect(aes(xmin = q2,xmax = q8),fill = "lightblue",colour = "black") +
  geom_rect(aes(xmin = q3,xmax = q7),fill = "dodgerblue",colour = "black") +
  geom_rect(aes(xmin = q4,xmax = q6),fill = 'blue',colour = "black") +
  #geom_rect(aes(xmin = q5,xmax = q5),fill = 'midnightblue',colour = "black") +
  theme_classic() +
  theme(axis.line.y=element_blank(),
        axis.ticks.y=element_blank(),
        axis.text.y=element_blank(),
        plot.title = element_text(hjust = 0.5, size=16),
        axis.text = element_text(size=10, color="black"),
        text = element_text(size=14)) +
  labs(x=xlablab,y="") +
  coord_cartesian(xlim=tics) +
  scale_x_continuous(breaks = tics)

graph_combined <- ggarrange(BF, GL, ncol=1, nrow=2, align="v")
x <- annotate_figure(graph_combined, top = text_grob(paste("Percentiles - ",dataset,sep = ""),size = 16))

ggsave(paste(dataset,"_decile.pdf",sep=""), plot=x, width = 8, height = 5, units = "in", device = 'pdf',bg = "transparent")


# Examples of empirical correlation matrix computation using cov function

## Read chains

chains <- read.table(file="chain01.csv", header=FALSE, sep=",")

## Compute correlation matrix

print(cov(chains))


x <- c(10.4, 5.6, 3.1, 6.4, 21.7) # c means 'combine', basically create an array?
cat("x: ", x, "\n")
y <- mean(x) # average
cat("mean of x: ", y, "\n")
z <- sd(x) # standard deviation
cat("std dev of x: ", z, "\n")


N = 20
n = 9
p1 = 5 / 20
p2 = 6 / 20
p3 = 9 / 20

X <- t(as.matrix(expand.grid(0:n, 0:n)))
X <- X[, colSums(X) <= n]
X <- rbind(X, n - colSums(X))
dimnames(X) <- list(letters[1:3])
mul <- X[1,] * X[2,]
mul <- mul * X[3,]
mul_nonzero_idx = which(mul!=0, arr.ind=T)
Y <- X[, mul_nonzero_idx]

result <- round(apply(Y, 2, function(x) dmultinom(x, prob=c(p1, p2, p3))), 4)

print(sum(result))


library(Cairo)
library(Hmisc)

params   = read.table('data/cycleParams.csv',sep=',',header=T)
filtered = read.table('data/filteredSingleCellData.csv',sep=',',header=T)

attach(params)

subset = filtered$well == 'D6'
histBins = c(-Inf, seq( from=14, to=16.5, length.out=20), Inf)

CairoSVG('singleCellNorm.svg',height=3,width=12)
par(mfrow=c(1,4))

ylims = c(14,17)
xlims = c(13.2,13.7)

plot( log2(filtered$totalIntensity.1[subset]),
      log2(filtered$totalIntensity.2[subset]),
      pch=16, col=rgb(0,0,0,.2), xlim=xlims, ylim=ylims )
fit = lm( log2(filtered$totalIntensity.2[subset]) ~
          log2(filtered$totalIntensity.1[subset]) )
abline(fit,col='gray',lwd=3)
legend('topleft', paste('r =',round(
    rcorr( log2(filtered$totalIntensity.2[subset]),
           log2(filtered$totalIntensity.1[subset]),
          type='pearson')$r[2],2)),text.col='red',bty='n')

plot( log2(filtered$totalIntensity.1[subset]),
      log2(filtered$denoisedTotalIntensityMult.2[subset]),
      pch=16, col=rgb(0,0,0,.2),main='multiplicative', xlim=xlims, ylim=ylims )
fit = lm( log2(filtered$denoisedTotalIntensityMult.2[subset]) ~
            log2(filtered$totalIntensity.1[subset]) )
abline(fit,col='red',lwd=2)
legend('topleft', paste('r =',round(
  rcorr( log2(filtered$denoisedTotalIntensityMult.2[subset]),
         log2(filtered$totalIntensity.1[subset]),
         type='pearson')$r[2],2)),text.col='red',bty='n')

plot( log2(filtered$totalIntensity.1[subset]),
      log2(filtered$denoisedTotalIntensity.2[subset]),
      pch=16, col=rgb(0,0,0,.2),main='regression', xlim=xlims, ylim=ylims )
fit = lm( log2(filtered$denoisedTotalIntensity.2[subset]) ~
            log2(filtered$totalIntensity.1[subset]) )
abline(fit,col='dodgerblue',lwd=2)
legend('topleft', paste('r =',round(
  rcorr( log2(filtered$denoisedTotalIntensity.2[subset]),
         log2(filtered$totalIntensity.1[subset]),
         type='pearson')$r[2],2)),text.col='red',bty='n')

plot( log2(filtered$totalIntensity.2[subset]),
      log2(filtered$denoisedTotalIntensity.2[subset]),
      pch=16, main='shuffling',col= rgb(0,0,0,.2),cex=.5,
      xlim=ylims, ylim=ylims )

dev.off()


# Number Names

ones <- c("", "one", "two", "three", "four", "five", "six", "seven", "eight", "nine",
          "ten", "eleven", "twelve", "thirteen", "fourteen", "fifteen", "sixteen", "seventeen", "eighteen", "nineteen")
tens <- c("ten", "twenty", "thirty", "forty", "fifty", "sixty", "seventy", "eighty", "ninety")
mags <- c("", "thousand", "million", "billion", "trillion", "quadrillion", "quintillion")

return_hund <- function(input_number){
  if (input_number == 0) return("")
  num_text <- as.character()
  input_hund <- trunc(input_number / 100)
  input_ten <- trunc((input_number - input_hund * 100) / 10)
  input_one <- input_number %% 10
  if (input_number > 99) num_text <- paste0(ones[trunc(input_number / 100) + 1], "-hundred")
  if (input_ten < 2){
    if (input_ten == 0 & input_one == 0) return(num_text)
    if (input_hund > 0) return(paste0(num_text, " ", ones[input_ten * 10 + input_one + 1]))
    return(paste0(ones[input_ten * 10 + input_one + 1]))
  }
  ifelse(input_hund > 0,
         num_text <- paste0(num_text, " ", tens[input_ten]),
         num_text <- paste0(tens[input_ten])
  )
  if (input_one != 0) num_text <- paste0(num_text, "-", ones[input_one + 1])
  return(num_text)
}

make_number <- function(number){
  if (number == 0) return("zero")
  a <- abs(number)
  num_text <- as.character()
  g <- trunc(log(a, 10)) + 1
  for (i in c(seq(g, 1))){
    b <- floor(a / 1000 ^ (i - 1))
    x <- return_hund(b)
    if (x != "") num_text <- paste0(num_text, return_hund(b), " ", mags[i], " ")
    a <- a - b * 1000 ^ (i - 1)
  }
  return(ifelse(sign(number) > 0, num_text, paste("negative", num_text)))
}

my_num <- data.frame(nums = c(
  0, 1, -11, 13, 99, 100, -101, 113, -120, 450, -999, 1000, 1001, 1017, 3000, 3001,
  9999, 10000, 10001, 10100, 10101, 19000, 20001, 25467, 99999, 100000, 1056012,
  -200000, 200001, -200012, 2012567, -5685436, 5000201, -11627389, 100067652, 456000342)
)

my_num$text <- as.character(lapply(my_num$nums, make_number))
print(my_num, right=F)


source("logistic_regression_data.r")
summary(glm(y_0 ~ X_0, family = "binomial"))

library(rstan)
rstan_options(auto_write = TRUE)

compiled.model.prior <- stan_model("stan/simple_logistic_regression_prior.stan")

# lgr.data <- list(
#   N0 = N_0,
#   X0 = X_0,
#   y0 = y_0,
#   a_0 = .15
# )

############
### Unnormalised posterior

compiled.model.unnorm.posterior <- stan_model("stan/simple_logistic_regression_posterior_unnormalised.stan")

lgr.data.forposterior <- list(
  N0 = N_0,
  X0 = X_0,
  y0 = y_0,
  delta = delta,
  nu = nu,
  X = X,
  N = N,
  y = y
)

unnorm.posterior.lgr <- sampling(compiled.model.unnorm.posterior, data = lgr.data.forposterior)
unnorm.posterior.lgr
pairs(unnorm.posterior.lgr, pars = c("a_0", "beta"))

### The approximately normalised prior

constant_data <- read.csv("../data/RegressionLogistic_logCA0.csv")
library(mgcv)
fit.gam <- mgcv::gam(lc_a0 ~ s(a0), data = constant_data)

plot(constant_data$a0, predict.gam(fit.gam), type = "l")
points(lc_a0 ~ a0 , constant_data)

approx.normalised.model <- stan_model("stan/simple_logistic_regression_posterior_approximate.stan")

Ks <- c(50, 100, 1000, 10000)

get_posterior_K <- function(K){
  pred_a0s <- seq(0, max(constant_data$a0), length.out = K)
  a0_grid <- data.frame(a0 = pred_a0s,
                        lc_pred = predict(fit.gam, newdata = data.frame(a0 = pred_a0s)))
  lgr.data.forposterior$pred_grid_x <- a0_grid$a0
  lgr.data.forposterior$pred_grid_y <- a0_grid$lc_pred
  approx.norm.posterior.lgr <- sampling(approx.normalised.model,
                                          data = lgr.data.forposterior, refresh = 0)
  return(approx.norm.posterior.lgr)
}

system.time(
  all.approximates <- lapply(Ks, get_posterior_K)
)

##### Analysis of p(a_0 | data)
a0.unnorm <- extract(unnorm.posterior.lgr, 'a_0')$a_0

a0.approx.list <- lapply(Ks, function(k){
  i <- match(k, Ks)
  a0 <- extract(all.approximates[[i]], 'a_0')$a_0
  return(data.frame(a0 = a0, normalisation = paste("K=", k, sep = "")))
} )

a0.dt <-
  rbind(
    data.frame(a0 = a0.unnorm,
               normalisation = rep("unnormalised", length(a0.unnorm))
    ),
    do.call(rbind, a0.approx.list)
  )

library(ggplot2)

a0_dist <- ggplot(a0.dt, aes(x = a0, fill = normalisation, colour = normalisation)) +
  geom_density() +
  stat_function(fun = function(x) dbeta(x, delta, nu),
                geom = "line", colour = "black", linetype = "longdash") +
  ggtitle("Logistic regression") +
  facet_grid(normalisation~., scales = "free") +
  scale_y_continuous("Density", expand = c(0, 0)) +
  scale_x_continuous(expression(a[0]), expand = c(0, 0)) +
  theme_bw(base_size = 20)

a0_dist

ggsave("../figures/a0_posterior_RegressionLogistic.pdf", a0_dist)

a0_dist_norm <- ggplot(subset(a0.dt, normalisation != "unnormalised"),
                       aes(x = normalisation, y = a0,
                           fill = normalisation, colour = normalisation)) +
  geom_boxplot(alpha = .4) +
  ggtitle("Logistic regression") +
  scale_y_continuous(expression(a[0]), expand = c(0, 0)) +
  theme_bw(base_size = 20)

a0_dist_norm

ggsave("../figures/a0_posterior_RegressionLogistic_normalisation_comparison.pdf", a0_dist_norm)

###
unnorm.pars <- as.data.frame(
  cbind(extract(unnorm.posterior.lgr, 'alpha')$alpha,
  extract(unnorm.posterior.lgr, 'beta')$beta)
)
names(unnorm.pars) <- c("alpha", paste("beta_", 1:4, sep = ""))

##

app.norm.pars.list <- lapply(all.approximates, function(x) {
  pars <- as.data.frame(
    cbind(extract(x, 'alpha')$alpha,
          extract(x, 'beta')$beta
          )
  )
  names(pars) <- c("alpha", paste("beta_", 1:4, sep = ""))
  return(pars)
})

library(reshape2)
app.norm.pars.df.list <- lapply(seq_along(app.norm.pars.list), function(i) {
  y <- app.norm.pars.list[[i]]
  dt <- melt(y, variable.name = "parameter", value.name = "sample")
  dt$normalisation <- paste("K=", Ks[i] ,sep = "")
  return(dt)
} )

##

unnorm.dt <- melt(unnorm.pars, variable.name = "parameter", value.name = "sample")
unnorm.dt$normalisation <- "unnormalised"

posterior.dt <- rbind(unnorm.dt, do.call(rbind, app.norm.pars.df.list))
posterior.dt$normalisation <- factor(posterior.dt$normalisation,
                                     levels = c("unnormalised", paste("K=", Ks, sep = "")) )

###

true.pars <- data.frame(parameter = names(unnorm.pars), value = c(true.alpha, true.betas))

parameter_posteriors <- ggplot(data = posterior.dt, aes(x = sample, colour = normalisation, fill = normalisation)) +
  geom_density(alpha = .4) +
  scale_x_continuous("") +
  scale_y_continuous("Density", expand = c(0, 0)) +
  facet_wrap(.~parameter,  scales = "free") +
  geom_vline(data = true.pars, aes(xintercept = value), linetype = "dashed") +
  theme_bw(base_size = 16)

parameter_posteriors

ggsave("../figures/parameter_posterior_LogisticRegression.pdf", parameter_posteriors)