# Consensus Mechanism
# Paul Sztorc
# Written in R (v 3.1.1) using Rstudio (v 0.98.1028)

# This is the mechanism that, theoretically,
 #   1] allows the software to determine the state of Decisions truthfully, and
 #   2] only allows an efficient number of most-traded-upon-Decisions.

# To my knowledge, R does not feature 'automatic working directories' unless it is being run as a script
# try(setwd("~/GitHub/Truthcoin/lib/consensus"))
source("CustomMath.r")

## Functions:

DemocracyRep <- function(X) {
  # Run this if no Reputations were given...gives everyone an equal share and equal vote.

  Dem_Rep <- ReWeight(rep(1,nrow(X)))
  return( Dem_Rep )
}

BinaryScales <- function(X, IndexOnly=FALSE) {
  # Run this if no Scales were provided..assumes none were Scaled, all are Binary (0 or 1).

  Bin_Scales <- matrix( c( rep(FALSE,ncol(X)),
                       rep(0,ncol(X)),
                       rep(1,ncol(X))), 3, byrow=TRUE, dimnames=list(c("Scaled","Min","Max"),colnames(X)) )

  if(IndexOnly) return( as.logical( Bin_Scales["Scaled",] ) )
  return( Bin_Scales )
}

GetDecisionOutcomes <- function(Mtemp, Rep = DemocracyRep(Mtemp), ScaledIndex = BinaryScales(Mtemp, TRUE), Verbose=FALSE) {
  # Determines the (raw) Outcomes of Decisions based on the provided reputation (weighted vote)

  if(Verbose) { print("****************************************************") ; print("Begin 'GetDecisionOutcomes'")}

  DecisionOutcomes.Raw  <- 1:ncol(Mtemp) # Declare this (filled below)

  for(i in 1:ncol(Mtemp)) {
    #For each column:
    Row <- ReWeight(Rep[!is.na(Mtemp[,i])]) # The Reputation of the row-players who DID provide judgements, rescaled to sum to 1.
    Col <- Mtemp[!is.na(Mtemp[,i]),i]       # The relevant Decision with NAs removed. ("What these row-players had to say about the Decisions they DID judge.")

    #Discriminate Based on Contract Type
    if(!ScaledIndex[i]) DecisionOutcomes.Raw[i] <- Row %*% Col                   # Our Current best-guess for this Binary Decision (weighted average)
    if(ScaledIndex[i]) DecisionOutcomes.Raw[i] <- weighted.median(w=Row, x=Col)  # Our Current best-guess for this Scaled Decision (weighted median)

    if(Verbose) { print("** **"); print("Column:"); print(i); print(AsMatrix(Row)); print(Col); print("Consensus:"); print(DecisionOutcomes.Raw[i]) }
  }

  #Output
  return(DecisionOutcomes.Raw)
}

# M <- matrix( data=c(
#       1,    1,    0,    0,    0.5356322, 6.689658e-01,
#       1,    0,    0,    0,    0.4574713,           NA,
#       1,    1,    0,    0,    0.5356322, 6.689658e-01,
#       1,    1,    1,    0,    0.5747126,           NA,
#       0,    0,    1,    1,    1.0000000, 8.333333e-05,
#       0,    0,    1,    1,    1.0000000, 9.999167e-01),
#   nrow=6,byrow=TRUE)

# > GetDecisionOutcomes(Mtemp=M, ScaledIndex=c(FALSE, FALSE, FALSE, FALSE, TRUE, TRUE))
# [1] 0.6666667 0.5000000 0.5000000 0.3333333 0.5551724 0.6689658
# > GetDecisionOutcomes(Mtemp=M, ScaledIndex=c(FALSE, FALSE, FALSE, FALSE, FALSE, TRUE))
# [1] 0.6666667 0.5000000 0.5000000 0.3333333 0.6839080 0.6689658
# > GetDecisionOutcomes(Mtemp=M, ScaledIndex=c(TRUE, FALSE, FALSE, FALSE, FALSE, FALSE), Rep=c(.2,.2,.1,.4,.04,.06))
# [1] 1.0000000 0.7000000 0.5000000 0.1000000 0.5820690 0.6517202

GetRewardWeights <- function(M, Rep=DemocracyRep(M), ScaledIndex = BinaryScales(M, TRUE), alpha=.1, Tol=.2, Verbose=FALSE, RBCR=6) {
  # Calculates the new reputations using WPCA

  if(Verbose) {
    print("****************************************************")
    print("Begin 'GetRewardWeights'")
    print("Inputs...")
    print("Matrix:")
    print(M)
    print("")
    print("Reputation:")
    print(AsMatrix(Rep))
    print("")
  }

  Results <- WeightedPrinComp(M,Rep)

  FirstLoading <- Results$Loadings #The first loading is designed to indicate which Decisions were more 'agreed-upon' than others.
  FirstScore   <- Results$Scores   #The scores show loadings on consensus (to what extent does this observation represent consensus?)

  if(Verbose) { print("First Loading:"); print(FirstLoading); print("First Score:"); print(AsMatrix(FirstScore)) }

  # Skip all of this if there is pefect consensus (ie, all people agree).

  # Declared here, filled below (unless there was a perfect consensus).
  NewRep <- Rep # By default, reputations don't change if everyone agrees.

  if( ! sum(abs(FirstScore))==0 ) {

    ## Choosing Among Two Score-Persepectives

    # Now we have some work to do on the FirstScore.

    # PCA, being an abstract factorization, is incapable of determining anything absolute.
    # Therefore the results of the entire procedure would theoretically be reversed if the average state of Decisions changed from TRUE to FALSE.
    # Because the average state of Decisions is a function both of randomness and the way the Decisions are worded, I check to see which of the
    # two possible 'new' reputation vectors had more opinion in common with the original 'old' reputation.

    # The two options:
    Option1 <-  FirstScore + abs( min(FirstScore) )
    Option2 <-  abs( FirstScore - max(FirstScore) )

    # For each option:

    Score_Reflect <- function( Component, Previous_Reputation ) {
      # Takes an adjusted score, and breaks it at a median point.

      # Only if there actually is a median point.
      if( length( unique(Component) ) <= 2 ) return(Component)

      # If the Reps are calculated directly, there is an exploit in generating "sacrificial variance" and passing it to a teammate.
      # Although initially the sac-var is zero-sum (pointless), after reweighting it can become helpful to attackers.

      # Instead, a simple adjustment:
      MedianFactor <- weighted.median(Component, w = Previous_Reputation) # Which component is in the center?
      # This central value will be the next maximum, NOT the value opposite the most-deviant.

      # By how much does the component exceed the Median?
      Reflection <- Component - MedianFactor
      # Where does the Component exceed the Median?
      Excessive <- ( Reflection > 0 )

      # Declare and Fill Answer
      AdjPrinComp <- Component
      AdjPrinComp[ Excessive ] <- Component[ Excessive ] - (  Reflection[ Excessive ] * 0.5  ) # Mixes in some of the old method.
      # Check: max(Component) == MedianFactor # TRUE

      return(AdjPrinComp)
    }

    NewScore_1 <- Score_Reflect(Option1, Rep)
    NewScore_2 <- Score_Reflect(Option2, Rep)

    # Now, by what criteria do we compare the options?
    # (This should be easy, because one option will be the opposite of truth, but it deserves some thought nonetheless.)

    Method <- RBCR # All of these work very well, but I'm pretty sure that Method 6 is the best.

    if( Method == 1 ) {
      # Statistics Method
      # "Which set would produce more representative results?"

      New1 <- GetWeight(Set1) %*% M  # reweight to the reputation units first, then calculate what outcomes would resolve to using this Rep
      New2 <- GetWeight(Set2) %*% M

      RefInd <- sum( (New1-Old)^2 ) -  sum( (New2-Old)^2 ) # squared errors

    }

    if( Method == 2 ) {
      # Mathematics Method
      # "Which set moves the results the shortest distance?"

      New1 <- Set1 %*% M # Do not change units at all (only shift one observation to zero, and remove negatives).
      New2 <- Set2 %*% M # Notice that Set1 and Set2 already have the same max and min.

      RefInd <- sum( abs(New1-Old)) -  sum( abs(New2-Old))  # Raw errors, no squaring.

    }

    if( Method == 3 ) {
      # Rank Method
      # "Which set moves the direction the least?"

      rOld <- rank(Old)

      # Same as method 2, but focusing only on rank order. The logic being that we are focusing on the measurement of a single direction here.
      New1 <- rank( (GetWeight(Set1) %*% M) + 0.01*Old ) # I add Old because rank will erase data if final values are non-unique values
      New2 <- rank( (GetWeight(Set2) %*% M) + 0.01*Old )

      RefInd <- sum( abs(New1-rOld) ) - sum( abs(New2-rOld) )  # Raw errors, no squaring.

      if(RefInd==0) { # If the ranks are a tie, go back to Method 1

        New1 <- GetWeight(Set1) %*% M
        New2 <- GetWeight(Set2) %*% M

        RefInd <- sum( (New1-Old)^2 ) -  sum( (New2-Old)^2 ) # squared errors
      }
    }

    if( Method == 4 ) {
      # Norm Method - Operating Logic Unknown

      # Caluclate Potential Outcomes
      New1 <- GetDecisionOutcomes(M, GetWeight(Set1), ScaledIndex)
      New2 <- GetDecisionOutcomes(M, GetWeight(Set2), ScaledIndex)

      # Absolute Differences in Outcome
      Choice1 <- abs( New1 - Old )
      Choice2 <- abs( New2 - Old )

      # Absolute Relevance of Dissagreement
      Dissent <- abs(FirstLoading)

      RefInd <- (Choice1 %*% Dissent) - (Choice2 %*% Dissent)
    }

    if( Method == 5 | Method == 6 ) {
      # Use Old Reputation to calculate outcomes.
      # Examine each voter's agreement with these outcomes.
      # Collapse this agreement using this period's Loading.

      # Old Outcomes
      Old_raw <- GetDecisionOutcomes(M, Rep, ScaledIndex) # Outcomes under the previous period's reputation
      # Bin non-scaled modes into < 0, .5, 1 > using Catch()
      Old_c <- vapply(Old_raw, FUN = Catch, Tolerance = Tol, FUN.VALUE = 1)
      Old_f <- Old_c ;  Old_f[ScaledIndex] <- Old_raw[ScaledIndex]

      # Build distance matrix: absolute value of difference between "Group Outcomes (using Old)" and "Individual Outcomes"
      Distance <- abs(  M - ( array(1, dim(M)) %*% diag(Old_f) )  )

      # Separately, build index of question-cohesion
      Dissent <- abs(FirstLoading) # FirstLoading is higher when people disagree, lower when people agree, zero for perfect agreement.
      Dissent[Dissent==0] <- NA # Remove Zeros (zeros are irrelevant, not infinitely important), avoid division-by-zero problems
      Mainstream <- ReWeight( 1/Dissent )

      # Integrate the Two
      NonCompliance <- Distance %*% t(t(Mainstream))
      Compliance <- ReWeight(  abs( NonCompliance - max(NonCompliance) )  )

      # Compare - Which score has more error when it is matched up against compliance?
      Choice1 <- sum( (GetWeight(NewScore_1) - Compliance)^2 )  # Reweight is absolutely required here, as the components will always sum to different values.
      Choice2 <- sum( (GetWeight(NewScore_2) - Compliance)^2 )

      # When RefInd becomes positive, switch to Set2.
      RefInd <- Choice1 - Choice2  # When Choice1 has greater error, this will be positive.

    }

    # Rep/mean(Rep) is a correction ensuring Reputation is additive. Therefore, nothing can be gained by splitting/combining Reputation into single/multiple accounts.
    Rep1 <- GetWeight( (NewScore_1 * Rep/mean(Rep)) )
    Rep2 <- GetWeight( (NewScore_2 * Rep/mean(Rep)) )

    # The Reference Index is a measurement of error, if >0, then New1 had higher errors (use New2), and conversely if <0 use 1.
    if(RefInd <  0 ) NewRep <- Rep1
    if(RefInd >= 0 ) NewRep <- Rep2

  }

  if(Verbose) {

    print("")
    print(paste(" %% Reference Index %% :",RefInd))
    print("Estimations using: Previous Rep, Option 1, Option 2")
    print(  cbind( AsMatrix(Old_f), AsMatrix( GetDecisionOutcomes(M, Rep1, ScaledIndex) ), AsMatrix( GetDecisionOutcomes(M, Rep2, ScaledIndex) ) )  )
    print("")
    print("Previous period reputations, Option 1, Option 2, Raw1, Raw2, Selection")
    print(  cbind( AsMatrix(Rep), AsMatrix(Rep1), AsMatrix(Rep2), AsMatrix(NewScore_1), AsMatrix(NewScore_2), AsMatrix(NewRep) )  )

  }

  # Freshly-Calculated Reward (Reputation) - Exponential Smoothing
  # New Reward: NewRep
  # Old Reward: Rep
  SmoothedR <- alpha*(NewRep) + (1-alpha)*Rep

  if(Verbose) {
    print("")
    print("Corrected for Additivity , Smoothed _1 period")
    print( cbind( AsMatrix(NewRep), AsMatrix(SmoothedR)) )
  }

  # Return Data
  Out <- list("FirstL"=FirstLoading,"OldRep"=Rep,"ThisRep"=NewRep,"SmoothRep"=SmoothedR)  # Keep the factors and time information along for the ride, they are interesting.
  return(Out)
}

# M <- matrix(nrow=3,byrow=TRUE,data=c(1,0,1,0,
#                                      1,0,1,0,
#                                      1,0,0,1))
#
# M2 <- matrix(nrow=3,byrow=TRUE,data=c(.80, .1, .72, 0,
#                                       .80, .1, .62, 0,
#                                       .43, .1, .00, 1))
#
# > GetRewardWeights(M)
# $FirstL
# [1]  0.0000000  0.0000000 -0.7071068  0.7071068
# $OldRep
# [1] 0.3333333 0.3333333 0.3333333
# $ThisRep
# [1] 0.5 0.5 0.0
# $SmoothRep
# [1] 0.35 0.35 0.30
#
# > GetRewardWeights(M, Rep=c(.2,.2,.6), Tol = .1)
# $FirstL
# [1]  0.0000000  0.0000000 -0.7071068  0.7071068
# $OldRep
# [1] 0.2 0.2 0.6
# $ThisRep
# [1] 0 0 1
# $SmoothRep
# [1] 0.18 0.18 0.64
#
# > GetRewardWeights(M2)
# $FirstL
# [1] -0.2934226  0.0000000 -0.5338542  0.7930340
# $OldRep
# [1] 0.3333333 0.3333333 0.3333333
# $ThisRep
# [1] 0.505356 0.494644 0.000000
# $SmoothRep
# [1] 0.3505356 0.3494644 0.3000000
#
# > GetRewardWeights(M2, Rep=c(.2,.2,.6), alpha=.5, Verbose = TRUE)
# [1] "****************************************************"
# [1] "Begin 'GetRewardWeights'"
# [1] "Inputs..."
# [1] "Matrix:"
# [,1] [,2] [,3] [,4]
# [1,] 0.80  0.1 0.72    0
# [2,] 0.80  0.1 0.62    0
# [3,] 0.43  0.1 0.00    1
# [1] ""
# [1] "Reputation:"
# [,1]
# [1,]  0.2
# [2,]  0.2
# [3,]  0.6
# [1] ""
# [1] "First Loading:"
# [1] -0.2935984  0.0000000 -0.5330507  0.7935092
# [1] "First
# [1] "Previous period reputations, Option 1, Option 2, Raw1, Raw2, Selection"
# [,1]       [,2]      [,3]       [,4]      [,5]       [,6]
# [1,]  0.2 0.00000000 0.5105824 0.00000000 0.6429686 0.00000000
# [2,]  0.2 0.01362912 0.4894176 0.05330507 0.6163160 0.01362912
# [3,]  0.6 0.98637088 0.0000000 1.28593716 0.0000000 0.98637088
# [1] ""
# [1] "Corrected for Additivity , Smoothed _1 period"
# [,1]      [,2]
# [1,] 0.00000000 0.1000000
# [2,] 0.01362912 0.1068146
# [3,] 0.98637088 0.7931854
# $FirstL
# [1] -0.2935984  0.0000000 -0.5330507  0.7935092
#
# $OldRep
# [1] 0.2 0.2 0.6
#
# $ThisRep
# [1] 0.00000000 0.01362912 0.98637088
#
# $SmoothRep
# [1] 0.1000000 0.1068146 0.7931854

# Score:"
# [,1]
# [1,] -0.7822233
# [2,] -0.7289182
# [3,]  0.5037139
# [1] ""
# [1] " %% Reference Index %% : -1.26355970920342"
# [1] "Estimations using: Previous Rep, Option 1, Option 2"
# [,1]        [,2]      [,3]
# [1,]  0.5 0.435042774 0.8000000
# [2,]  0.0 0.100000000 0.1000000
# [3,]  0.0 0.008450054 0.6710582
# [4,]  0.5 0.986370881 0.0000000
# [1] ""

FillNa <- function(Mna, Rep = DemocracyRep(Mna), ScaledIndex = BinaryScales(Mna), CatchP=.1, Verbose=FALSE) {
  # Uses exisiting data and reputations to fill missing observations.
  # Essentially a weighted average using all availiable non-NA data.
  # How much should slackers who arent voting suffer? I decided this would depend on the global percentage of slacking.

  Mnew <- Mna # Declare (in case no Missing values, Mnew, MnewC, and Mna will be the same)
  MnewC <- Mna

  if(sum(is.na(Mna))>0) {
    #Of course, only do this process if there ARE missing values.

    if(Verbose) print("Missing Values Detected. Beginning presolve using availiable values.")

    #Decision Outcome - Our best guess for the Decision state (FALSE=0, Ambiguous=.5, TRUE=1) so far (ie, using the present, non-missing, values).
    DecisionOutcomes.Raw <- GetDecisionOutcomes(Mna,Rep,ScaledIndex,Verbose)

    #Fill in the predictions to the original M
    NAmat <- is.na(Mna)   #Defines the slice of the matrix which needs to be edited.
    Mnew[NAmat] <- 0       #Erase the NA's

    #Slightly complicated:
    NAsToFill <- ( NAmat%*%diag(as.vector(DecisionOutcomes.Raw)) )
    #   This builds a matrix whose columns j:
        #          NAmat was false (the observation wasn't missing)     ...  have a value of Zero
        #          NAmat was true (the observation was missing)         ...  have a value of the jth element of DecisionOutcomes.Raw (the 'current best guess')
    Mnew <- Mnew + NAsToFill
    #This replaces the NAs, which were zeros, with the predicted Decision outcome.

    if(Verbose) { print("Missing Values:"); print(NAmat) ; print("Imputed Values:"); print(NAsToFill)}

    #Declare Output
    MnewC <- Mnew
    ## Discriminate based on contract type
    #Fill ONLY Binary contracts by appropriately forcing predictions into their discrete (0,.5,1) slot. (reveals .5 coordination, continuous variables are more gameable).
    MnewC[,!ScaledIndex] <- apply(Mnew[,!ScaledIndex], c(1,2), function(x) Catch(x,Tolerance = CatchP) )
    #

  }

  if(Verbose) { print("Raw Results:"); print(Mnew) ; print("Binned:"); print(MnewC) ; print("*** ** Missing Values Filled ** ***") }

  return(MnewC)
}

# M <- matrix( data=c(
#       1,    1,     0,     0,    0.5356322, 6.689658e-01,
#       1,    0,    NA,    NA,    0.4574713,           NA,
#       1,    NA,    0,    NA,    0.5356322, 6.689658e-01,
#       1,    1,     1,    NA,    0.5747126,           NA,
#       0,    NA,    1,    NA,    1.0000000, 8.333333e-05,
#       0,    0,     1,     1,    NA,        9.999167e-01),
#   nrow=6,byrow=TRUE)

# > FillNa(M,ScaledIndex=c(FALSE,FALSE,FALSE,FALSE,TRUE,TRUE))
#       [,1] [,2] [,3] [,4]      [,5]         [,6]
# [1,]    1  1.0    0  0.0 0.5356322 6.689658e-01
# [2,]    1  0.0    1  0.5 0.4574713 6.689658e-01
# [3,]    1  0.5    0  0.5 0.5356322 6.689658e-01
# [4,]    1  1.0    1  0.5 0.5747126 6.689658e-01
# [5,]    0  0.5    1  0.5 1.0000000 8.333333e-05
# [6,]    0  0.0    1  1.0 0.5356322 9.999167e-01
# > FillNa(M,ScaledIndex=c(FALSE,FALSE,FALSE,FALSE,FALSE,FALSE))
#       [,1] [,2] [,3] [,4] [,5] [,6]
# [1,]    1  1.0    0  0.0  0.5    1
# [2,]    1  0.0    1  0.5  0.5    1
# [3,]    1  0.5    0  0.5  0.5    1
# [4,]    1  1.0    1  0.5  1.0    1
# [5,]    0  0.5    1  0.5  1.0    0
# [6,]    0  0.0    1  1.0  1.0    1

#Putting it all together:
Factory <- function(M0, Scales = BinaryScales(M0), Rep = DemocracyRep(M0), CatchP=.2, MaxRow=5000, Verbose=FALSE, RBCR = 6) {
  # Main Routine

  ScaledIndex=as.logical( Scales["Scaled",] )
  MScaled <- Rescale(M0, Scales)

  #Handle Missing Values
  Filled <- FillNa(MScaled, Rep, ScaledIndex, CatchP, Verbose)

  ## Consensus - Row Players
  # New Consensus Reward
  PlayerInfo <- GetRewardWeights(M = Filled, Rep, ScaledIndex, alpha = .1, Tol = CatchP, Verbose, RBCR)
  AdjLoadings <- PlayerInfo$FirstL

  ## Column Players (The Decision Creators)
  # Calculation of Reward for Decision Authors
  # Consensus - "Who won?" Decision Outcome
  DecisionOutcomes.Raw <- PlayerInfo$SmoothRep %*% Filled # Declare (all binary), Simple matrix multiplication ... highest information density at RowBonus, but need DecisionOutcomes.Raw to get to that
  for(i in 1:ncol(Filled)) {    # slow implementation.. 'for loop' bad on R, much faster on python
    # Discriminate Based on Contract Type
    if(ScaledIndex[i]) DecisionOutcomes.Raw[i] <- weighted.median(Filled[,i], w=PlayerInfo$SmoothRep)  #Our Current best-guess for this Scaled Decision (weighted median)
  }

  # The Outcome Itself
  # Discriminate Based on Contract Type
  DecisionOutcome.Adj <- mapply(Catch,DecisionOutcomes.Raw,Tolerance=CatchP) # Declare first (assumes all binary)
  DecisionOutcome.Adj[ScaledIndex] <- DecisionOutcomes.Raw[ScaledIndex]      # Replace Scaled with raw (weighted-median)
  DecisionOutcome.Final <- t( Scales["Max",] - Scales["Min",] ) %*% diag( DecisionOutcome.Adj )    # Rescale these back up.
  DecisionOutcome.Final <- DecisionOutcome.Final + Scales["Min",]                                  # Recenter these back up.

  # Quality of Outcomes - is there confusion?

  Certainty <- vector("numeric",ncol(Filled))
  # For each Decision
  for(i in 1:ncol(Filled)) {
    # Sum of, the reputations which, met the condition that they voted for the outcome which was selected for this Decision.
    Certainty[i] <- sum( PlayerInfo$SmoothRep [ DecisionOutcome.Final[i] == Filled[,i] ] )
  }
  Avg.Certainty <- mean(Certainty)    # How well did beliefs converge?

  # Stability of Voter Reports is not the same as "Clear Instructions" (one can be 'certain' that something was 'unclear' if you all agree it was).
  # Want to discourage .5's
  Resolveable <- Filled!=.5
  MaxClairity <- Rep %*% Resolveable # All of the answers for .5 are an instant-veto on Clairity. If 30% said 'unclear' can't do better than 70%.
  Clarity <- MaxClairity * Certainty

  ConReward <- GetWeight(Clarity)   # Grading Authors on a curve. -not necessarily the best idea?

  if(Verbose) {
    print("*Decision Outcomes Sucessfully Calculated*")
    Temp <- rbind(DecisionOutcomes.Raw, Certainty, ConReward)
    row.names(Temp) <- c("Raw Outcomes", "Certainty", "AuthorPayoutFactor")
    print(Temp)
  }

  ## Participation

  #Information about missing values
  NAmat <- M0*0
  NAmat[is.na(NAmat)] <- 1 #indicator matrix for missing

  #Participation Within Decisions (Columns)
  # % of reputation that answered each Decision
  ParticipationC <- 1-(PlayerInfo$SmoothRep%*%NAmat)

  #Participation Within Agents (Rows)
  # Many options

  # 1- Democracy Option - all Decisions treated equally.
  ParticipationR  <- 1-( apply(NAmat,1,sum)/ncol(M0) )

  #General Participation
  PercentNA <- 1-mean(ParticipationC)
  #(Possibly integrate two functions of participation?) Chicken and egg problem...

  if(Verbose) {
    print("*Participation Information*")
    print("Voter Turnout by question"); print( ParticipationC )
    print("Voter Turnout across questions"); print ( ParticipationR )
  }

  ## Combine Information
  # Row
  NAbonusR <- GetWeight(ParticipationR)
  RowBonus <- (NAbonusR*(PercentNA))+(PlayerInfo$SmoothR*(1-PercentNA))

  # Column
  NAbonusC <- GetWeight(ParticipationC)
  ColBonus <- (NAbonusC*(PercentNA))+(ConReward*(1-PercentNA))

  # Present Results
  Output <- vector("list",6) #Declare
  names(Output) <- c("Original","Filled","Agents","Decisions","Participation","Certainty")

  Output[[1]] <- M0
  Output[[2]] <- Filled
  Output[[3]] <- cbind(PlayerInfo$OldRep, PlayerInfo$ThisRep,PlayerInfo$SmoothRep,apply(NAmat,1,sum),ParticipationR,NAbonusR,RowBonus)
  colnames(Output[[3]]) <- c("OldRep", "ThisRep", "SmoothRep", "NArow", "ParticipationR","RelativePart","RowBonus")
  Output[[4]] <- rbind(AdjLoadings,DecisionOutcomes.Raw,ConReward,Certainty,apply(NAmat,2,sum),ParticipationC,ColBonus,DecisionOutcome.Final)
  rownames(Output[[4]]) <- c("First Loading","DecisionOutcomes.Raw","Consensus Reward","Certainty","NAs Filled","ParticipationC","Author Bonus","DecisionOutcome.Final")
  Output[[5]] <- (1-PercentNA) # Using this to set inclusion fees.
  Output[[6]] <- Avg.Certainty # Using this to set Catch Parameter

  return(Output)
}

# M1 <-  rbind(
#   c(1,1,0,0),
#   c(1,0,0,0),
#   c(1,1,0,0),
#   c(1,1,1,0),
#   c(0,0,1,1),
#   c(0,0,1,1))
#
# row.names(M1) <- c("True", "Distort 1", "True", "Distort 2", "Liar", "Liar")
# colnames(M1) <- c("D1.1","D2.1","D3.0","D4.0")
#
# > Factory(M1)
# $Original
# D1.1 D2.1 D3.0 D4.0
# True         1    1    0    0
# Distort 1    1    0    0    0
# True         1    1    0    0
# Distort 2    1    1    1    0
# Liar         0    0    1    1
# Liar         0    0    1    1
#
# $Filled
# D1.1 D2.1 D3.0 D4.0
# True         1    1    0    0
# Distort 1    1    0    0    0
# True         1    1    0    0
# Distort 2    1    1    1    0
# Liar         0    0    1    1
# Liar         0    0    1    1
#
# $Agents
# OldRep   ThisRep SmoothRep NArow ParticipationR RelativePart  RowBonus
# True      0.1666667 0.2823757 0.1782376     0              1    0.1666667 0.1782376
# Distort 1 0.1666667 0.2176243 0.1717624     0              1    0.1666667 0.1717624
# True      0.1666667 0.2823757 0.1782376     0              1    0.1666667 0.1782376
# Distort 2 0.1666667 0.2176243 0.1717624     0              1    0.1666667 0.1717624
# Liar      0.1666667 0.0000000 0.1500000     0              1    0.1666667 0.1500000
# Liar      0.1666667 0.0000000 0.1500000     0              1    0.1666667 0.1500000
#
# $Decisions
# D1.1       D2.1      D3.0      D4.0
# First Loading         -0.5395366 -0.4570561 0.4570561 0.5395366
# DecisionOutcomes.Raw   0.7000000  0.5282376 0.4717624 0.3000000
# Consensus Reward       0.5000000  0.0000000 0.0000000 0.5000000
# Certainty              0.7000000  0.0000000 0.0000000 0.7000000
# NAs Filled             0.0000000  0.0000000 0.0000000 0.0000000
# ParticipationC         1.0000000  1.0000000 1.0000000 1.0000000
# Author Bonus           0.5000000  0.0000000 0.0000000 0.5000000
# DecisionOutcome.Final  1.0000000  0.5000000 0.5000000 0.0000000
#
# $Participation
# [1] 1
#
# $Certainty
# [1] 0.35
#
#
#
# MS <- matrix( data=c(
#       1,    1,    0,    0,    233,   16027.59,
#       1,    0,    0,    0,    199,         NA,
#       1,    1,    0,    0,    233,   16027.59,
#       1,    1,    1,    0,    250,         NA,
#       0,    0,    1,    1,    435,    8001.00,
#       0,    0,    1,    1,    435,   19999.00),
#   nrow=6,byrow=TRUE, dimnames=list( rownames(M1), paste("D",1:6,sep=".")))
#
#
# Scales <- matrix( data=c(
#             0, 0, 0, 0,   1,     1,
#             0, 0, 0, 0,   0,  8000,
#             1, 1, 1, 1, 435, 20000),
#       nrow=3, byrow=TRUE, dimnames=list( c("Scaled","Min","Max"), colnames(MS)) )
#
#
# > Factory(M0=MS,Scales=Scales)
# $Original
# D.1 D.2 D.3 D.4 D.5      D.6
# True        1   1   0   0 233 16027.59
# Distort 1   1   0   0   0 199       NA
# True        1   1   0   0 233 16027.59
# Distort 2   1   1   1   0 250       NA
# Liar        0   0   1   1 435  8001.00
# Liar        0   0   1   1 435 19999.00
#
# $Filled
# D.1 D.2 D.3 D.4       D.5          D.6
# True        1   1   0   0 0.5356322 6.689658e-01
# Distort 1   1   0   0   0 0.4574713 6.689658e-01
# True        1   1   0   0 0.5356322 6.689658e-01
# Distort 2   1   1   1   0 0.5747126 6.689658e-01
# Liar        0   0   1   1 1.0000000 8.333333e-05
# Liar        0   0   1   1 1.0000000 9.999167e-01
#
# $Agents
# OldRep    ThisRep SmoothRep NArow ParticipationR RelativePart  RowBonus
# True      0.1666667 0.27512698 0.1775127     0      1.0000000    0.1764706 0.1774530
# Distort 1 0.1666667 0.22080941 0.1720809     1      0.8333333    0.1470588 0.1706477
# True      0.1666667 0.27512698 0.1775127     0      1.0000000    0.1764706 0.1774530
# Distort 2 0.1666667 0.21600171 0.1716002     1      0.8333333    0.1470588 0.1701944
# Liar      0.1666667 0.00000000 0.1500000     0      1.0000000    0.1764706 0.1515162
# Liar      0.1666667 0.01293492 0.1512935     0      1.0000000    0.1764706 0.1527356
#
# $Decisions
# D.1         D.2        D.3       D.4         D.5           D.6
# First Loading         -0.5223889 -0.43411264 0.44195128 0.5223889   0.2463368 -9.880889e-02
# DecisionOutcomes.Raw   0.6987065  0.52662557 0.47289366 0.3012935   0.5356322  6.689658e-01
# Consensus Reward       0.2850531  0.00000000 0.00000000 0.2850531   0.1448406  2.850531e-01
# Certainty              0.6987065  0.00000000 0.00000000 0.6987065   0.3550254  6.987065e-01
# NAs Filled             0.0000000  0.00000000 0.00000000 0.0000000   0.0000000  2.000000e+00
# ParticipationC         1.0000000  1.00000000 1.00000000 1.0000000   1.0000000  6.563189e-01
# Author Bonus           0.2788520  0.01012676 0.01012676 0.2788520   0.1466709  2.753716e-01
# DecisionOutcome.Final  1.0000000  0.50000000 0.50000000 0.0000000 233.0000000  1.602759e+04
#
# $Participation
# [1] 0.9427198
#
# $Certainty
# [1] 0.4085242
#
# > Factory(M0=MS,Scales=Scales,Rep=c(.05,.05,.05,.05,.10,.70))
# $Original
#           D.1 D.2 D.3 D.4 D.5      D.6
# True        1   1   0   0 233 16027.59
# Distort 1   1   0   0   0 199       NA
# True        1   1   0   0 233 16027.59
# Distort 2   1   1   1   0 250       NA
# Liar        0   0   1   1 435  8001.00
# Liar        0   0   1   1 435 19999.00
#
# $Filled
#           D.1 D.2 D.3 D.4       D.5          D.6
# True        1   1   0   0 0.5356322 6.689658e-01
# Distort 1   1   0   0   0 0.4574713 9.999167e-01
# True        1   1   0   0 0.5356322 6.689658e-01
# Distort 2   1   1   1   0 0.5747126 9.999167e-01
# Liar        0   0   1   1 1.0000000 8.333333e-05
# Liar        0   0   1   1 1.0000000 9.999167e-01
#
# $Agents
#           OldRep    ThisRep  SmoothRep NArow ParticipationR RelativePart   RowBonus
# True        0.05 0.00000000 0.04500000     0      1.0000000    0.1764706 0.04702833
# Distort 1   0.05 0.01235137 0.04623514     1      0.8333333    0.1470588 0.04779064
# True        0.05 0.00000000 0.04500000     0      1.0000000    0.1764706 0.04702833
# Distort 2   0.05 0.01332745 0.04633275     1      0.8333333    0.1470588 0.04788674
# Liar        0.10 0.11962886 0.10196289     0      1.0000000    0.1764706 0.10311239
# Liar        0.70 0.85469232 0.71546923     0      1.0000000    0.1764706 0.70715357
#
# $Decisions
#                              D.1        D.2       D.3       D.4         D.5          D.6
# First Loading         -0.5369880 -0.4210132 0.4240200 0.5369880   0.2540098 4.149213e-02
# DecisionOutcomes.Raw   0.1825679  0.1363327 0.8637649 0.8174321   1.0000000 9.999167e-01
# Consensus Reward       0.1638874  0.1731571 0.1731767 0.1638874   0.1638874 1.620038e-01
# Certainty              0.8174321  0.8636673 0.8637649 0.8174321   0.8174321 8.080371e-01
# NAs Filled             0.0000000  0.0000000 0.0000000 0.0000000   0.0000000 2.000000e+00
# ParticipationC         1.0000000  1.0000000 1.0000000 1.0000000   1.0000000 9.074321e-01
# Author Bonus           0.1639706  0.1730973 0.1731166 0.1639706   0.1639706 1.618743e-01
# DecisionOutcome.Final  0.0000000  0.0000000 1.0000000 1.0000000 435.0000000 1.999900e+04
#
# $Participation
# [1] 0.984572
#
# $Certainty
# [1] 0.8312943

# Double-Factory (more reliable)

DoubleFactory <- function(X, Scales = BinaryScales(X), Rep = DemocracyRep(X), CatchP=.1, MaxRow=5000, Phi=.65, Verbose=FALSE) {
  # see http://forum.truthcoin.info/index.php/topic,102.msg289.html#msg289

  WaveOne <- Factory(X,Scales,Rep,CatchP,MaxRow,Verbose)

  Safe  <- ( WaveOne$Decisions["Certainty",] ) >= Phi # all those contracts which were unanimous for a subset of proportion ("Phi")

  if(Verbose) {
    print(" Wave One Complete.")
    print( sum(Safe)/ncol(X) )
  }

  WaveTwo <- Factory( X[,Safe] ,
                      Scales[,Safe],
                      Rep,CatchP,MaxRow,Verbose)

  return(WaveTwo)
}

# M1 is defined above

# > DoubleFactory(M1)
# $Original
#           D1.1 D4.0
# True         1    0
# Distort 1    1    0
# True         1    0
# Distort 2    1    0
# Liar         0    1
# Liar         0    1
#
# $Filled
#           D1.1 D4.0
# True         1    0
# Distort 1    1    0
# True         1    0
# Distort 2    1    0
# Liar         0    1
# Liar         0    1
#
# $Agents
#              OldRep ThisRep SmoothRep NArow ParticipationR RelativePart RowBonus
# True      0.1666667    0.25     0.175     0              1    0.1666667    0.175
# Distort 1 0.1666667    0.25     0.175     0              1    0.1666667    0.175
# True      0.1666667    0.25     0.175     0              1    0.1666667    0.175
# Distort 2 0.1666667    0.25     0.175     0              1    0.1666667    0.175
# Liar      0.1666667    0.00     0.150     0              1    0.1666667    0.150
# Liar      0.1666667    0.00     0.150     0              1    0.1666667    0.150
#
# $Decisions
#                             D1.1      D4.0
# First Loading         -0.7071068 0.7071068
# DecisionOutcomes.Raw   0.7000000 0.3000000
# Consensus Reward       0.5000000 0.5000000
# Certainty              0.7000000 0.7000000
# NAs Filled             0.0000000 0.0000000
# ParticipationC         1.0000000 1.0000000
# Author Bonus           0.5000000 0.5000000
# DecisionOutcome.Final  1.0000000 0.0000000
#
# $Participation
# [1] 1
#
# $Certainty
# [1] 0.7

# M2 <- matrix( data=c(
#   c(0.5, 0.5, 1,  0),
#   c(0.5, 0.0, 1,  0),
#   c(0.5, 1.0, 1,  0),
#   c(1.0,  NA, 1, NA),
#   c(0.5, 1.0, 1,  1),
#   c(0.0, 0.0, 1,  1)), nrow=6, byrow=TRUE, dimname=list(paste("V",1:6,sep="."), colnames(M1)) )
#
# > DoubleFactory(M2)
# $Original
#     D1.1 D3.0 D4.0
# V.1  0.5    1    0
# V.2  0.5    1    0
# V.3  0.5    1    0
# V.4  1.0    1   NA
# V.5  0.5    1    1
# V.6  0.0    1    1
#
# $Filled
#     D1.1 D3.0 D4.0
# V.1  0.5    1    0
# V.2  0.5    1    0
# V.3  0.5    1    0
# V.4  1.0    1    0
# V.5  0.5    1    1
# V.6  0.0    1    1

# $Agents
#        OldRep    ThisRep SmoothRep NArow ParticipationR RelativePart  RowBonus
# V.1 0.1666667 0.22833653 0.1728337     0      1.0000000    0.1764706 0.1730484
# V.2 0.1666667 0.22833653 0.1728337     0      1.0000000    0.1764706 0.1730484
# V.3 0.1666667 0.22833653 0.1728337     0      1.0000000    0.1764706 0.1730484
# V.4 0.1666667 0.27166347 0.1771663     1      0.6666667    0.1176471 0.1736514
# V.5 0.1666667 0.04332693 0.1543327     0      1.0000000    0.1764706 0.1556401
# V.6 0.1666667 0.00000000 0.1500000     0      1.0000000    0.1764706 0.1515632
#
# $Decisions
#                             D1.1      D3.0      D4.0
# First Loading         -0.4241554 0.0000000 0.9055894
# DecisionOutcomes.Raw   0.5135832 1.0000000 0.3043327
# Consensus Reward       0.1168147 0.5208482 0.3623371
# Certainty              0.6728337 1.0000000 0.6956673
# NAs Filled             0.0000000 0.0000000 1.0000000
# ParticipationC         1.0000000 1.0000000 0.8228337
# Author Bonus           0.1308368 0.5110099 0.3581533
# DecisionOutcome.Final  0.5000000 1.0000000 0.0000000
#
# $Participation
# [1] 0.9409446
#
# $Certainty
# [1] 0.7895003


DataDir = "../data/pixel-based"

SoilCovars = read.csv(file.path(DataDir, "soil", "landgis-rerun.csv"))
SoilGrids = read.csv(file.path(DataDir, "soil", "soilgrids-rerun.csv"))
SoilGrids[SoilGrids==2^16-1] = NA

sum(complete.cases(SoilGrids)) / nrow(SoilGrids) # 39% of the cases are complete
CovarNAs = apply(SoilGrids, 2, function(x){sum(is.na(x)) / nrow(SoilGrids)})
sort(CovarNAs) # 2% missing from each, 50% missing from 8 covars, 12% from 7 more

ncol(SoilGrids) # 375
SmallerMatrix = SoilGrids[,-which(CovarNAs > 0.03)]
ncol(SmallerMatrix) # 336 covars
sum(complete.cases(SmallerMatrix)) / nrow(SmallerMatrix) # 92% of complete cases
nrow(SmallerMatrix)
# Drop taxonomy altogether
SmallerMatrix[,grep("TAX", names(SmallerMatrix))] = NULL
ncol(SmallerMatrix) # 152
sum(complete.cases(SmallerMatrix)) / nrow(SmallerMatrix) # Still 92% of complete cases

# Merge LandGIS with SoilGrids
MergedData = merge(SoilCovars, SmallerMatrix, by="location_id")
nrow(MergedData) == nrow(SmallerMatrix) # Nothing is lost (except points outside Africa in SoilCovars)
sum(complete.cases(MergedData)) / nrow(MergedData) # 92% of complete cases, very slightly fewer

# Write to file
write.csv(MergedData, file.path(DataDir, "covariates", "soil-merged.csv"), row.names=FALSE)

cor(MergedData[,c("sol_ph.0cm", "PHIHOX.M.sl1")], use="complete")
plot(sol_bulkdens.0cm~BLDFIE.M.sl1, MergedData)
plot(sol_bulkdens.10cm~BLDFIE.M.sl2, MergedData)
plot(sol_bulkdens.30cm~BLDFIE.M.sl4, MergedData)
plot(sol_bulkdens.60cm~BLDFIE.M.sl5, MergedData)
plot(sol_bulkdens.100cm~BLDFIE.M.sl6, MergedData)
plot(sol_bulkdens.200cm~BLDFIE.M.sl7, MergedData)
# We know bulk density correlates with water content
plot(sol_bulkdens.0cm~AWCtS.M.sl1, MergedData) # Little correlation
plot(BLDFIE.M.sl1~AWCtS.M.sl1, MergedData) # Extreme correlation
text(MergedData$AWCtS.M.sl1)

library(plotly)
plot_ly(MergedData, x=~BLDFIE.M.sl1, y=~AWCtS.M.sl1, text=~location_id)
plot_ly(MergedData, x=~sol_bulkdens.200cm, y=~AWCtS.M.sl1, text=~location_id)

plot(sol_clay.0cm~CLYPPT.M.sl1, MergedData)
plot(sol_clay.10cm~CLYPPT.M.sl2, MergedData)
plot(sol_clay.30cm~CLYPPT.M.sl4, MergedData)
plot(sol_clay.60cm~CLYPPT.M.sl5, MergedData)
plot(sol_clay.100cm~CLYPPT.M.sl6, MergedData)
plot(sol_clay.200cm~CLYPPT.M.sl7, MergedData)

plot(sol_sand.0cm~SNDPPT.M.sl1, MergedData)
plot(sol_sand.10cm~SNDPPT.M.sl2, MergedData)
plot(sol_sand.30cm~SNDPPT.M.sl4, MergedData)
plot(sol_sand.60cm~SNDPPT.M.sl5, MergedData)
plot(sol_sand.100cm~SNDPPT.M.sl6, MergedData)
plot(sol_sand.200cm~SNDPPT.M.sl7, MergedData)

plot(sol_organic.0cm~ORCDRC.M.sl1, MergedData)
plot(sol_organic.10cm~ORCDRC.M.sl2, MergedData)
plot(sol_organic.30cm~ORCDRC.M.sl4, MergedData)
plot(sol_organic.60cm~ORCDRC.M.sl5, MergedData)
plot(sol_organic.100cm~ORCDRC.M.sl6, MergedData)
plot(sol_organic.200cm~ORCDRC.M.sl7, MergedData)
hist(MergedData$sol_organic.200cm, breaks=100)
hist(MergedData$ORCDRC.M.sl7, breaks=100)
hist(log(MergedData$sol_organic.200cm+1), breaks=100)
hist(log(MergedData$ORCDRC.M.sl7+1), breaks=100)
plot(log(sol_organic.0cm+1)~log(ORCDRC.M.sl1+1), MergedData)
plot(log(sol_organic.10cm+1)~log(ORCDRC.M.sl2+1), MergedData)
plot(log(sol_organic.30cm+1)~log(ORCDRC.M.sl4+1), MergedData)
plot(log(sol_organic.60cm+1)~log(ORCDRC.M.sl5+1), MergedData)
plot(log(sol_organic.100cm+1)~log(ORCDRC.M.sl6+1), MergedData)
plot(log(sol_organic.200cm+1)~log(ORCDRC.M.sl7+1), MergedData)
# Not much correlation

plot(sol_ph.0cm~PHIHOX.M.sl1, MergedData)
plot(sol_ph.10cm~PHIHOX.M.sl2, MergedData)
plot(sol_ph.30cm~PHIHOX.M.sl4, MergedData)
plot(sol_ph.60cm~PHIHOX.M.sl5, MergedData)
plot(sol_ph.100cm~PHIHOX.M.sl6, MergedData)
plot(sol_ph.200cm~PHIHOX.M.sl7, MergedData)

# there is no correlation *at all*. Fantastic

# When I retry, the values are much different! So something must have changed in the mean while.


# ==================================================
log10_minor_break = function (...){
  function(x) {
    minx         = floor(min(log10(x), na.rm=T))-1;
    maxx         = ceiling(max(log10(x), na.rm=T))+1;
    n_major      = maxx-minx+1;
    major_breaks = seq(minx, maxx, by=1)
    minor_breaks =
      rep(log10(seq(1, 9, by=1)), times = n_major)+
      rep(major_breaks, each = 9)
    return(10^(minor_breaks))
  }
}
# ==================================================
# install.packages("R.matlab");
# install.packages("R.oo");
# install.packages("comprehenr");
# install.packages("ggplot2");
# install.packages("reshape2");
# install.packages("latex2exp");
# install.packages("scales");
# install.packages("patchwork");
setwd("~/git/AC-CFM")
library(R.matlab)
library(R.oo)
library(comprehenr)
library(ggplot2)
library(reshape2)
library(latex2exp)
library(scales)
library(patchwork)
LINES <- 5
LOADLOST_ALL <- 20
LOADLOST_LINES <- 19
NETWORK <- 2
BUS <- 3
PD <- 3
BASEMVA <- 2
RES <- 1e-4
# load shed <- load lost
# loglog for all
# ==================================================

casebase <- "118bus_lowdamp_pgliblimits"
methods <- c("acopf","scacopf","fpacopf_09","fpacopf_12","fpacopf_15")
methodlabs <- c("acopf","scacopf","exitrates_1e09","exitrates_1e12","exitrates_1e15")
protections <- c("allprotection","ol_vls_50")
limitscales <- c("1_05","1_10","1_15","1_20")
plottypes <- c("lines","loadlost_all")#,"loadserved_all")

paper_plot <- function(plottype,casebase,methods,methodlabs,protections,limitscales,frac_or_pu,number_or_proportion,alternate_formatting,cond_or_uncond,plotting){
  fnames <- c()
  fids <- c()
  dataout <- list()
  dataavg <- list()
  datastd <- list()
  datamedcond <- list()
  for (protection in protections) {
    for (limitscale in limitscales) {
      ##
      ## get data
      ##
      maxlength <- 0
      dataynumber <- vector("list", length(methodlabs))
      datayproportion <- vector("list", length(methodlabs))
      dataxnumber <- vector("list", length(methodlabs))
      dataxproportion <- vector("list", length(methodlabs))
      if (plottype == "lines"){
        plotname <- paste(limitscale,"/",plottype,"_",number_or_proportion,"_",protection,"_",sep='')
        if (alternate_formatting == TRUE){
          (fnameout <- paste("figures/",plotname,casebase,"_alt.pdf",sep=''))
        } else {
          (fnameout <- paste("figures/",plotname,casebase,".pdf",sep=''))
        }
        show(fnameout)
      }
      else {
        plotname <- paste(limitscale,"/",plottype,"_",frac_or_pu,"_",number_or_proportion,"_",protection,"_",sep='')
        if (alternate_formatting == TRUE) {
          (fnameout <- paste("figures/",plotname,casebase,"_alt.pdf",sep=''))
        } else {
          (fnameout <- paste("figures/",plotname,casebase,".pdf",sep=''))
        }
        show(fnameout)
      }
      for (k in 1:length(methods)) {
        method <- methods[k]
        show(c(protection,limitscale,method))
        fid <- paste("cascades_",casebase,"_",method,"_",protection,"_",limitscale,sep='')
        fids <- c(fids,fid)
        fname <- paste("output/",fid,".mat",sep='')
        fnames <- c(fnames,fname)
        df <- readMat(fname)[[1]]
        if (plottype=="lines") {
          yprepre <- data.frame("rawcounts"=rowSums(df[[LINES]]))
          ypre <- yprepre$rawcounts
          if (cond_or_uncond == "cond") {
            x <- 1:max(ypre)
          } else {
            x <- 0:max(ypre)
          }
          y <- to_vec(for (v in x) sum((ypre >= v)))
          if (cond_or_uncond == "cond") {
            mask <- (y > 0);
          } else {
            mask <- rep(TRUE,length(y));
          }
          xx <- x[mask];
          yy <- y[mask];
          avg <- mean(ypre,na.rm=TRUE)
          std <- sd(ypre,na.rm=TRUE)
          medcond <- median(ypre[(ypre > 0)],na.rm=TRUE)
          if (number_or_proportion == "proportion"){
            xlabel <- "L: Number of failed lines"
            ylabel <- "Pr(Number of failed lines >= L)"
          }
          else {
            xlabel <- "L: Number of failed lines"
            ylabel <- "Number of cascades with failed lines >= L"
          }
        } else if (plottype=="loadlost_all") {
          totalloadpu <- sum(df[[NETWORK]][[BUS]][,PD])/df[[NETWORK]][[BASEMVA]][1,1]
          frac <- df[[LOADLOST_ALL]]
          pu <- frac*totalloadpu
          yprepre <- data.frame("loadlostpu"=pu,"loadlostfrac"=frac)
          if (frac_or_pu == "pu") {
            ypre <- yprepre$loadlostpu
            x <- seq(from=0,to=1,by=RES)*totalloadpu
            y <- to_vec(for (v in x) sum((ypre >= v)))
            if (cond_or_uncond == "cond") {
              mask <- (y > 0) & (x > 0)
            } else {
              mask <- rep(TRUE,length(y));
            }
            xx <- x[mask];
            yy <- y[mask];
            avg <- mean(ypre,na.rm=TRUE)
            std <- sd(ypre,na.rm=TRUE)
            medcond <- median(ypre[(ypre > 0)],na.rm=TRUE)
            if (number_or_proportion == "proportion"){
              xlabel <- "x: Load shed (p.u.)"
              ylabel <- "Pr(Load shed >= x)"
            } else {
              xlabel <- "x: Load shed (p.u.)"
              ylabel <- "Number of cascades with load shed >= x"
            }

          } else if (frac_or_pu == "frac") {
            ypre <- yprepre$loadlostfrac
            x <- seq(from=0,to=1,by=RES)
            y <- to_vec(for (v in x) sum((ypre >= v)))
            if (cond_or_uncond == "cond") {
              mask <- (y > 0) & (x > 0)
            } else {
              mask <- rep(TRUE,length(y));
            }
            xx <- x[mask];
            yy <- y[mask];
            avg <- mean(ypre,na.rm=TRUE)
            std <- sd(ypre,na.rm=TRUE)
            medcond <- median(ypre[(ypre > 0)],na.rm=TRUE)
            if (number_or_proportion == "proportion"){
              xlabel <- "x: Load shed (fraction)"
              ylabel <- "Pr(Load shed >= x)"
            } else {
              xlabel <- "x: Load lost (fraction)"
              ylabel <- "Number of cascades with load shed >= x"
            }
          }
        } else if (plottype=="loadserved_all") {
          totalloadpu <- sum(df[[NETWORK]][[BUS]][,PD])/df[[NETWORK]][[BASEMVA]][1,1]
          frac <- 1-df[[LOADLOST_ALL]]
          pu <- frac*totalloadpu
          yprepre <- data.frame("loadservedpu"=pu,"loadservedfrac"=frac)
          if (frac_or_pu == "pu") {
            ypre <- yprepre$loadservedpu
            if (cond_or_uncond == "cond") {
              ypre <- ypre[(ypre < totalloadpu)] # remove non-failure scenarios
            }
            x <- seq(from=0,to=1,by=RES)*totalloadpu
            y <- to_vec(for (v in x) sum((ypre >= v)))
            if (cond_or_uncond == "cond") {
              mask <- (y > 0) & (x < totalloadpu)
            } else {
              mask <- rep(TRUE,length(y));
            }
            xx <- x[mask];
            yy <- y[mask];
            avg <- mean(ypre,na.rm=TRUE)
            std <- sd(ypre,na.rm=TRUE)
            medcond <- median(ypre[(ypre > 0)],na.rm=TRUE)
            if (number_or_proportion == "proportion"){
              xlabel <- "x: Load served (p.u.)"
              ylabel <- "Pr(Load served >= x)"
            } else {
              xlabel <- "x: Load served (p.u.)"
              ylabel <- "Number of cascades with load served >= x"
            }
          } else if (frac_or_pu == "frac") {
            ypre <- yprepre$loadservedfrac
            if (cond_or_uncond == "cond") {
              ypre <- ypre[(ypre < 1)] # remove non-failure scenarios
            }
            x <- seq(from=0,to=1,by=RES)
            y <- to_vec(for (v in x) sum((ypre >= v)))
            if (cond_or_uncond == "cond") {
              mask <- (y > 0) & (x < 1)
            } else {
              mask <- rep(TRUE,length(y));
            }
            xx <- x[mask];
            yy <- y[mask];
            avg <- mean(ypre,na.rm=TRUE)
            std <- sd(ypre,na.rm=TRUE)
            medcond <- median(ypre[(ypre > 0)],na.rm=TRUE)
            if (number_or_proportion == "proportion"){
              xlabel <- "x: Load served (fraction)"
              ylabel <- "Pr(Load served >= x)"
            } else {
              xlabel <- "x: Load served (fraction)"
              ylabel <- "Number of cascades with load served >= x"
            }
          }
        }
        if (cond_or_uncond == "uncond") {
          ## manually remove first "0" data point since ggplot will mess up the transformation
          ncascs_with_failure <- max(yy);
          yyproportion <- yy[2:length(yy)]/ncascs_with_failure
          dataynumber[[k]] <- yy[2:length(yy)]
          datayproportion[[k]] <- yyproportion
          dataxnumber[[k]] <- xx[2:length(xx)]
          dataxproportion[[k]] <- xx[2:length(xx)]
          maxlength <- max(maxlength,max(length(yy)))
        } else {
          ncascs_with_failure <- max(yy);
          yyproportion <- yy/ncascs_with_failure
          dataynumber[[k]] <- yy
          datayproportion[[k]] <- yyproportion
          dataxnumber[[k]] <- xx
          dataxproportion[[k]] <- xx
          maxlength <- max(maxlength,max(length(yy)))
        }
        dataavg[[paste(protection,":",limitscale,":",method,":avg",sep='')]] <- avg
        datastd[[paste(protection,":",limitscale,":",method,":std",sep='')]] <- std
        datastd[[paste(protection,":",limitscale,":",method,":medcond",sep='')]] <- medcond
      }

      ## pad each series
      for (k in 1:length(methodlabs)) {
        dataynumber[[k]] <- c(dataynumber[[k]], rep(NA, maxlength-length(dataynumber[[k]])))
        datayproportion[[k]] <- c(datayproportion[[k]], rep(NA, maxlength-length(datayproportion[[k]])))
        dataxnumber[[k]] <- c(dataxnumber[[k]], rep(NA, maxlength-length(dataxnumber[[k]])))
        dataxproportion[[k]] <- c(dataxproportion[[k]], rep(NA, maxlength-length(dataxproportion[[k]])))
      }
      methodlabsy <- to_vec(for (m in methodlabs) paste(m,"_y",sep=''))
      methodlabsx <- to_vec(for (m in methodlabs) paste(m,"_x",sep=''))
      dataynumber <- as.data.frame(dataynumber); names(dataynumber) <- methodlabsy
      datayproportion <- as.data.frame(datayproportion); names(datayproportion) <- methodlabsy
      dataxnumber <- as.data.frame(dataxnumber); names(dataxnumber) <- methodlabsx
      dataxproportion <- as.data.frame(dataxproportion); names(dataxproportion) <- methodlabsx
      datanumber <- cbind(dataynumber,dataxnumber)
      dataproportion <- cbind(datayproportion,dataxproportion)

      ##
      ## make plot
      ##
      if (plotting == TRUE) {
        if (number_or_proportion == "number") {
          data <- datanumber
        } else if (number_or_proportion == "proportion") {
          data <- dataproportion
        }
        dataout[[paste(protection,":",limitscale,sep='')]] <- data
        # if (alternate_formatting == TRUE){
        #   pdf(fnameout)
        # } else {
        #   pdf(fnameout)
        # }
        sp <- ggplot(data=data) +
              geom_line(aes(x=acopf_x, y=acopf_y, color = "N-0")) +
              geom_line(aes(x=scacopf_x, y=scacopf_y, color = "N-1")) +
              geom_line(aes(x=exitrates_1e09_x, y=exitrates_1e09_y, color = "lambda = 1e-09")) +
              geom_line(aes(x=exitrates_1e12_x, y=exitrates_1e12_y, color = "lambda = 1e-12")) +
              geom_line(aes(x=exitrates_1e15_x, y=exitrates_1e15_y, color = "lambda = 1e-15")) +
              xlab(xlabel) +
              ylab(ylabel) +
              theme(plot.title = element_text(size = 11, face = "bold")) +
              scale_color_manual(values = c("N-0" = "red",
                                            "N-1" = "brown4",
                                            "lambda = 1e-09" = "blue",
                                            "lambda = 1e-12" = "forestgreen",
                                            "lambda = 1e-15" = "magenta"),
                                limits = c("N-0", "N-1",
                                            "lambda = 1e-09",
                                            "lambda = 1e-12",
                                            "lambda = 1e-15"),
                                # labels = c("N-0", "N-1",              #labels = c("N-0", "N-1",
                                #   expression("λ"^"lim"~"="~10^"-9"),  #expression("\U03BB"^"lim"~"="~10^"-9"),
                                #   expression("λ"^"lim"~"="~10^"-12"), #expression("\U03BB"^"lim"~"="~10^"-12"),
                                #   expression("λ"^"lim"~"="~10^"-15")) #expression("\U03BB"^"lim"~"="~10^"-15"))
                                labels = c("N-0", "N-1",
                                            unname(TeX(c(
                                              "$\\lambda^{\\mathrm{lim}}\\,=\\,10^{-9}$",
                                              "$\\lambda^{\\mathrm{lim}}\\,=\\,10^{-12}$",
                                              "$\\lambda^{\\mathrm{lim}}\\,=\\,10^{-15}$"
                                            ))))
              ) + labs(color = "")
              if (TRUE) {
                # http://www.sthda.com/english/wiki/ggplot2-axis-scales-and-transformations
                ### albert
                sp <- sp + scale_y_log10(breaks = trans_breaks("log10", function(x) 10^x, n=2),
                                        labels = trans_format("log10", math_format(10^.x)),
                                        minor_breaks=log10_minor_break())
                sp <- sp + scale_x_log10(breaks = trans_breaks("log10", function(x) 10^x, n=2),
                                        labels = trans_format("log10", math_format(10^.x)),
                                        minor_breaks=log10_minor_break())
                if (alternate_formatting == TRUE) {
                #  sp <- sp + theme_bw()# + annotation_logticks()
                sp <- sp + theme_bw(base_size = 16) + annotation_logticks(base = 10, sides = "lb")
                }
              } else {
                if (alternate_formatting == TRUE) {
                sp <- sp + theme_bw(base_size = 16)
                }
              }
              # print(sp)
              # dev.off()
              path = "/Users/jakeroth/git/AC-CFM"
              # ggsave(fnameout, device='png', path=path, dpi=700, width=8.96, height=6.44, units="in")
              ggsave(fnameout, device='pdf', path=path, width=8.96, height=6.44, units="in")
      }
    }
  }
  return(c(dataout,dataavg,datastd,datamedcond))
}

##
## proportion
##
cond_or_uncond <- "cond"
frac_or_pu <- "pu"
number_or_proportion <- "proportion"
alternate_formatting <- TRUE
plotting <- TRUE
for (plottype in plottypes){
  paper_plot(plottype,casebase,methods,methodlabs,protections,limitscales,frac_or_pu,number_or_proportion, alternate_formatting, cond_or_uncond)
}

cond_or_uncond <- "uncond"
frac_or_pu <- "pu"
number_or_proportion <- "proportion"
alternate_formatting <- TRUE
plotting <- TRUE
for (plottype in plottypes){
  paper_plot(plottype,casebase,methods,methodlabs,protections,limitscales,frac_or_pu,number_or_proportion, alternate_formatting, cond_or_uncond)
}

##
## number
##
cond_or_uncond <- "cond"
frac_or_pu <- "pu"
number_or_proportion <- "number"
alternate_formatting <- TRUE
plotting <- TRUE
for (plottype in plottypes){
  paper_plot(plottype,casebase,methods,methodlabs,protections,limitscales,frac_or_pu,number_or_proportion, alternate_formatting, cond_or_uncond,plotting)
}

cond_or_uncond <- "uncond"
frac_or_pu <- "pu"
number_or_proportion <- "number"
alternate_formatting <- TRUE
plotting <- TRUE
for (plottype in plottypes){
  paper_plot(plottype,casebase,methods,methodlabs,protections,limitscales,frac_or_pu,number_or_proportion, alternate_formatting, cond_or_uncond,plotting)
}

##
## paper
##
cond_or_uncond <- "uncond"
frac_or_pu <- "pu"
number_or_proportion <- "proportion"
alternate_formatting <- TRUE
plotting <- TRUE
for (plottype in plottypes){
  paper_plot(plottype,casebase,methods,methodlabs,protections,limitscales,frac_or_pu,number_or_proportion, alternate_formatting, cond_or_uncond,plotting)
}

cond_or_uncond <- "uncond"
frac_or_pu <- "pu"
number_or_proportion <- "number"
alternate_formatting <- TRUE
plotting <- FALSE
protections <- c("allprotection")
Dlines<-paper_plot("lines",casebase,methods,methodlabs,protections,limitscales,frac_or_pu,number_or_proportion, alternate_formatting, cond_or_uncond,plotting)
Dload<-paper_plot("loadlost_all",casebase,methods,methodlabs,protections,limitscales,frac_or_pu,number_or_proportion, alternate_formatting, cond_or_uncond,plotting)

avglines <- c(Dlines$`allprotection:1_20:acopf:avg`,
              Dlines$`allprotection:1_20:scacopf:avg`,
              Dlines$`allprotection:1_20:fpacopf_09:avg`,
              Dlines$`allprotection:1_20:fpacopf_12:avg`,
              Dlines$`allprotection:1_20:fpacopf_15:avg`)
avgload <-  c(Dload$`allprotection:1_20:acopf:avg`,
              Dload$`allprotection:1_20:scacopf:avg`,
              Dload$`allprotection:1_20:fpacopf_09:avg`,
              Dload$`allprotection:1_20:fpacopf_12:avg`,
              Dload$`allprotection:1_20:fpacopf_15:avg`)
avglines <- c(Dlines$`allprotection:1_20:acopf:avg`,
              Dlines$`allprotection:1_20:scacopf:avg`,
              Dlines$`allprotection:1_20:fpacopf_09:avg`,
              Dlines$`allprotection:1_20:fpacopf_12:avg`,
              Dlines$`allprotection:1_20:fpacopf_15:avg`)
stdlines <- c(Dlines$`allprotection:1_20:acopf:std`,
              Dlines$`allprotection:1_20:scacopf:std`,
              Dlines$`allprotection:1_20:fpacopf_09:std`,
              Dlines$`allprotection:1_20:fpacopf_12:std`,
              Dlines$`allprotection:1_20:fpacopf_15:std`)
stdload <-  c(Dload$`allprotection:1_20:acopf:std`,
              Dload$`allprotection:1_20:scacopf:std`,
              Dload$`allprotection:1_20:fpacopf_09:std`,
              Dload$`allprotection:1_20:fpacopf_12:std`,
              Dload$`allprotection:1_20:fpacopf_15:std`)
medcondlines <- c(Dlines$`allprotection:1_20:acopf:medcond`,
              Dlines$`allprotection:1_20:scacopf:medcond`,
              Dlines$`allprotection:1_20:fpacopf_09:medcond`,
              Dlines$`allprotection:1_20:fpacopf_12:medcond`,
              Dlines$`allprotection:1_20:fpacopf_15:medcond`)
medcondload <-  c(Dload$`allprotection:1_20:acopf:medcond`,
              Dload$`allprotection:1_20:scacopf:medcond`,
              Dload$`allprotection:1_20:fpacopf_09:medcond`,
              Dload$`allprotection:1_20:fpacopf_12:medcond`,
              Dload$`allprotection:1_20:fpacopf_15:medcond`)

labs <- c("N-0", "N-1",unname(TeX(c(
                                    "$\\lambda^{\\mathrm{lim}}\\,=\\,10^{-9}$",
                                    "$\\lambda^{\\mathrm{lim}}\\,=\\,10^{-12}$",
                                    "$\\lambda^{\\mathrm{lim}}\\,=\\,10^{-15}$"
                                    ))))
pdf(file="figures/avglines.pdf", width=8.96, height=6.44)
barplot(avglines, names.arg=labs); title("average lines failed")
dev.off()
pdf(file="figures/avgload.pdf", width=8.96, height=6.44)
barplot(avgload, names.arg=labs); title("average load lost")
dev.off()
# s <- ggplot(data=data.frame(xx=xx,yy=yy)) + geom_line(aes(x=xx,y=yy)) + scale_y_log10(breaks = trans_breaks("log10", function(x) 10^x, n=2),
#                                       labels = trans_format("log10", math_format(10^.x)),
#                                       minor_breaks=log10_minor_break()) + scale_x_log10(breaks = trans_breaks("log10", function(x) 10^x, n=2),
#                                       labels = trans_format("log10", math_format(10^.x)),
#                                       minor_breaks=log10_minor_break())

##
## proportion decrease stats
##

# D$`allprotection:1_20`
# > r=c(158,155,158,134,146)
# > 1000-r
# [1] 842 845 842 866 854
# > rr=r[1]
# > (r-rr)/r
# [1]  0.00000000 -0.01935484  0.00000000 -0.17910448 -0.08219178
# > (rr-r)/r
# [1] 0.00000000 0.01935484 0.00000000 0.17910448 0.08219178
# > z=1000-r
# > zz=z[1]
# > (zz-z)/z


#' @export
#' @title create_random_matrix
#' @description This function calculates depth in meters from pressure in decibars using Saunders and Fofonoff's method
#' @param \code{the.nrow} = desired number of rows (default is 5)
#' @param \code{the.ncol} = desired number of columns (default is 5)
#' @param \code{the.range} = the range of values to use (default is 1:100)
#' @return matrix of integers with the specified dimensions
#' @author  Mike McMahon, \email{Mike.McMahon@@dfo-mpo.gc.ca}
#' @family random data
#' @examples create.random.matrix(the.nrow=10, the.ncol=20, the.range=0:9)
#' @export
create_random_matrix<-function(the.nrow=10, the.ncol=2, the.range=1:50){
  return(matrix(sample(the.range, size = the.nrow*the.ncol, replace = TRUE), the.nrow, the.ncol))
}


pdf_file<-"pdf/maps_nuts2006.pdf"
cairo_pdf(bg="grey98", pdf_file,width=10,height=7)

par(omi=c(0,0,0,0),mai=c(0,0,0,0),family="Lato Light",las=1)
library(maptools)
library(rgdal)
library(RColorBrewer)

# Import data and prepare chart

myX<-readShapeSpatial("myData/NUTS-2006/NUTS_RG_03M_2006.shp",proj4string=CRS("+proj=longlat"))
m <- spTransform(myX, CRS=CRS("+proj=merc"))
colour<-sample(1:7,length(m),replace=T)
m$colour<-colour
palette<-brewer.pal(7,"Purples")

# Create chart

plot(m,xlim=c(-1000000,3000000),ylim=c(4000000,10000000),border=F,col=palette[m$colour])
dev.off()


#' Create a vector of colors for vertices and edges
#'
#' Using `vertex`/`edge` attributes, these functions return vectors of colors
#' that can be used either during the creation of the [nplot] object, or
#' afterwards when changing `gpar` (graphical parameter) values with [set_gpar].
#'
#' @param x A graph of class `network` or `igraph`.
#' @param dat A vector of data to generate the color from.
#' @param vattr,eattr Character. Names of either vertex or edge variables to be
#' used for generating the colors.
#' @param categorical Logical. When `TRUE` sets the colors as categories.
#' @param color_map A function to generate a palette.
#' @param ... Further arguments passed to `make_colors`.
#' @examples
#'
#' data(UKfaculty, package="igraphdata")
#' col <- make_vertex_colors(UKfaculty, "Group")
#'
#' if (require(magrittr)) {
#'
#'   nplot(UKfaculty) %>%
#'     set_vertex_gpar("core", fill = col, col=col) %>%
#'     set_vertex_gpar("frame", fill = col, col=col, alpha=.7) %>%
#'     set_edge_gpar(col="gray50", fill="gray50", alpha=.5)
#' }
#' @export
#' @return
#' A vector of colors with the attribute `color_map`. The color map used
#' to generate the colors.
make_colors <- function(
  dat,
  categorical = FALSE,
  color_map   = grDevices::hcl.colors
  ) {

  # What type of attribute?
  if (!categorical) {

    # Is is numeric?
    if (!is.numeric(dat))
      stop("The selected variable is not numeric.", call. = FALSE)

    # Moving to 0-1 scale
    dat     <- (dat - min(dat))/(diff(range(dat, na.rm = TRUE)) + 1e-15)
    color_map <- grDevices::colorRamp(color_map(20))
    color     <- grDevices::rgb(color_map(dat), maxColorValue = 255)

  } else {

    # Turning the data into factor
    dat <- as.factor(dat)

    # Generating as many colors as needed
    color_map <- structure(color_map(nlevels(dat)), names= levels(dat))
    color     <- color_map[as.integer(dat)]

  }

  structure(
    .Data = color,
    color_map = color_map
  )
}

#' @rdname make_colors
#' @export
make_edges_colors <- function(
  x,
  eattr,
  ...
  ) {

  make_colors(dat = get_edge_attr(x, eattr), ...)

}

#' @rdname make_colors
#' @details
#'
#' If no attribute is provided, then by defaul the colors are set according to
#' indegree.
#'
#' `x` can be either a graph of class `igraph` or `network`.
#'
#' @export
make_vertex_colors <- function(
  x,
  vattr,
  ...
) {

  if (!missing(vattr)) {
    vattr <- get_vertex_attr(x, vattr)
  } else
    vattr <- calc_degree(x, mode. = "in")

  make_colors(dat = vattr, ...)

}


#' Create a tidy stats data frame from an aov object
#'
#' \code{tidy_stats.aov} takes an aov object and converts the object to a tidy stats data frame.
#'
#' @param model Output of \code{aov} without within-subject factors.
#' @param args Unused.
#'
#' @examples
#' # Conduct an ANOVA
#' model_aov <- aov(yield ~ block + N * P * K, npk)
#'
#' # Tidy stats
#' tidy_stats(model_aov)
#'
#' @export

tidy_stats.aov <- function(model, args = NULL) {

  # Convert model output to a data frame
  output <- tibble::as_data_frame(summary(model)[[1]])

  # Rename columns
  output <- rename_columns(output)

  # Set term information
  output <- output %>%
    dplyr::mutate(
      term = row.names(data.frame(summary(model)[[1]])),
      term_nr = 1:n()
    )

  # Tidy stats
  output <- output %>%
    tidyr::gather("statistic", "value", -term, -term_nr) %>%
    dplyr::filter(!is.na(value)) %>%
    dplyr::arrange(term_nr)

  # Remove spaces from term
  output <- mutate(output, term = stringr::str_replace_all(term, " ", ""))

  # Determine the type of ANOVA
  classes <- attr(model$terms, "dataClasses")[-1]
  method <- dplyr::case_when(
    sum(classes == "numeric") > 0 ~ "ANCOVA",
    sum(classes == "factor" | classes == "character") == 1 ~ "One-way ANOVA",
    sum(classes == "factor" | classes == "character") == 2 ~ "Factorial ANOVA",
    TRUE ~ "ANOVA"
  )
  output <- mutate(output, method = method)

  # Reorder columns
  output <- dplyr::select(output, term_nr, everything())

  return(output)
}


##Ambientación = group
##lista=multiple raster
##Poligono=vector polygon
#Output=output raster
##Zonificacion=output vector
##Zonas=selection 2;3;4
##Reducir=number 2
##Area_ha=number 1

#27/07/2020- Franco Frolla - Derechos reservados.

if("psych" %in% rownames(installed.packages()) == FALSE) {install.packages("psych")} else {print("psych ya esta..")}
if("smoothr" %in% rownames(installed.packages()) == FALSE) {install.packages("smoothr")} else {print("smoothr ya esta..")}
if("e1071" %in% rownames(installed.packages()) == FALSE) {install.packages("e1071")} else {print("e1071 ya esta..")}
if("rgdal" %in% rownames(installed.packages()) == FALSE) {install.packages("rgdal")} else {print("rgdal ya esta..")}
if("units" %in% rownames(installed.packages()) == FALSE) {install.packages("units")} else {print("units ya esta..")}
if("rgeos" %in% rownames(installed.packages()) == FALSE) {install.packages("rgeos")} else {print("rgeos ya esta..")}

require(psych)
require(e1071)
require(rgeos)
require(smoothr)
require(units)

#Genero grilla para hacer los clusters
poligono <- as_Spatial(Poligono)
grid <- makegrid(poligono, cellsize = 5)
coordinates(grid)<-c("x1","x2")
proj4string(grid) <- crs(poligono)
recortegrilla <- raster::crop(grid,poligono)

#Genero un stack de imagenes raster

for (i in 1:length(lista)){
    lista[[i]]<-lista[[i]]/cellStats(lista[[i]], stat='mean', na.rm=TRUE)
    if (i>1){lista[[i]] <- resample(lista[[i]],lista[[1]])}
  }

lista<-stack(lista)

#Extraigo valores de cada capa normalizada.

nombres<-c("")
matrizdatos<-seq(1,length(recortegrilla),1)

for (i in 1:length(lista@layers)){
  print(i)
  data<-extract(lista[[i]],recortegrilla)
  matrizdatos<-cbind(matrizdatos,data)
  nombre<-lista[[i]]@data@names
  nombres<-c(nombres,nombre)

}

datos<-data.frame(matrizdatos,recortegrilla@coords[,1],recortegrilla@coords[,2])
colnames(datos)<-c(nombres,"x","y")

#SACO LA VARIABLE DUMMY
datos<-datos[2:ncol(datos)]
#elinimo datos inexistentes
datos<-na.omit(datos)

#Genero los clusters
if(Zonas==0){MC_2<-cmeans(datos[,2:ncol(datos)-2],2,100,method="cmeans",m=1.3)}
if(Zonas==1){MC_3<-cmeans(datos[,2:ncol(datos)-2],3,100,method="cmeans",m=1.3)}
if(Zonas==2){MC_4<-cmeans(datos[,2:ncol(datos)-2],4,100,method="cmeans",m=1.3)}

#Extraigo la data
if(Zonas==0){datos1<-cbind(datos,unname(MC_2$cluster))}
if(Zonas==0){colnames(datos1)<-c(colnames(datos),"zonas2")}
if(Zonas==1){datos1<-cbind(datos,unname(MC_3$cluster))}
if(Zonas==1){colnames(datos1)<-c(colnames(datos),"zonas3")}
if(Zonas==2){datos1<-cbind(datos,unname(MC_4$cluster))}
if(Zonas==2){colnames(datos1)<-c(colnames(datos),"zonas4")}

#datos1<-cbind(datos,unname(MC_2$cluster),unname(MC_3$cluster),unname(MC_4$cluster))
#colnames(datos1)<-c(colnames(datos),"zonas2","zonas3","zonas4")

coordinates(datos1)<-c("x","y")

>str(datos1)
>print(Zonas)

if(Zonas==0){r <- rasterFromXYZ(data.frame(datos1@coords[,1], datos1@coords[,2],datos1@data["zonas2"]))}
if(Zonas==1){r <- rasterFromXYZ(data.frame(datos1@coords[,1], datos1@coords[,2],datos1@data["zonas3"]))}
if(Zonas==2){r <- rasterFromXYZ(data.frame(datos1@coords[,1], datos1@coords[,2],datos1@data["zonas4"]))}

#Función para aplicar gdal_polygonize en R

gdal_polygonizeR <- function(x, outshape=NULL, gdalformat = 'ESRI Shapefile',
                             pypath=NULL, readpoly=TRUE, quiet=TRUE) {
  if (isTRUE(readpoly)) require(rgdal)
  if (is.null(pypath)) {
    pypath <- Sys.which('gdal_polygonize.py')
  }
  if (!file.exists(pypath)) stop("Can't find gdal_polygonize.py on your system.")
  owd <- getwd()
  on.exit(setwd(owd))
  setwd(dirname(pypath))
  if (!is.null(outshape)) {
    outshape <- sub('\\.shp$', '', outshape)
    f.exists <- file.exists(paste(outshape, c('shp', 'shx', 'dbf'), sep='.'))
    if (any(f.exists))
      stop(sprintf('File already exists: %s',
                   toString(paste(outshape, c('shp', 'shx', 'dbf'),
                                  sep='.')[f.exists])), call.=FALSE)
  } else outshape <- tempfile()
  if (is(x, 'Raster')) {
    require(raster)
    writeRaster(x, {f <- tempfile(fileext='.tif')})
    rastpath <- normalizePath(f)
  } else if (is.character(x)) {
    rastpath <- normalizePath(x)
  } else stop('x must be a file path (character string), or a Raster object.')
  system2('python', args=(sprintf('"%1$s" "%2$s" -f "%3$s" "%4$s.shp"',
                                  pypath, rastpath, gdalformat, outshape)))
  if (isTRUE(readpoly)) {
    shp <- readOGR(dirname(outshape), layer = basename(outshape), verbose=!quiet)
    return(shp)
  }
  return(NULL)
}
crs(r)<-crs(poligono)

vectorizado <- gdal_polygonizeR(r)
crs(vectorizado)<-crs(poligono)

#Suavizado

require(smoothr)
require(units)

vectorizado1 <- smooth(vectorizado, method = "ksmooth", smoothness = Reducir)

#REMUEVO POLIGONOS CON UN AREA MENOR A 1 ha
vectorizado1@data$area<-(raster::area(vectorizado1,na.rm=TRUE))/10000
vectorizado2 <- vectorizado1[vectorizado1$area > Area_ha,]

r <- raster(vectorizado2, res=5)
r <- rasterize(vectorizado2, r,field = vectorizado2$DN, background=NA)

#poligono2 = gUnaryUnion(poligono)
rpoly <- raster(poligono, res=5)
rpoligono <- rasterize(poligono, rpoly,background=0)
rpoligono[rpoligono] <- 0

r <- resample(r, rpoligono)
dif <- r - rpoligono
dif[dif == 0] <- NA

fill.na <- function(x) {
  center = 0.5 + (width*width/2)
  if( is.na(x)[center] ) {
    return( round(modal(x, na.rm=TRUE),0) )
  } else {
    return( round(x[center],0) )
  }
}

width = 13
r2 <- focal(r, w = matrix(1,width,width), fun = fill.na,
            pad = TRUE, na.rm = FALSE)

print("elimino bordes incorrectos")
ventana<-matrix(1,nrow=9,ncol=9)

r2 <-focal(r2,w=ventana,fun=modal,na.rm=TRUE)

vectorizado <- gdal_polygonizeR(r2)

print("generando buffer para solucionar problemas de geometria")

vectorizado <- gBuffer(vectorizado, width=0, byid = T)
vectorizado<-crop(vectorizado,poligono)

Zonificacion <- sf::st_as_sf(vectorizado)

#Output <- r


png("#13_scatter_plot.png" , width = 480, height = 480)
par(bg="white")
par(mar=c(0,0,0,0))
a=seq(1:100) + 0.1*seq(1:100)*sample(c(1:10) , 100 , replace=T)
b=seq(1:100) + 0.2*seq(1:100)*sample(c(1:10) , 100 , replace=T)
plot(a,b , xlim=c(10,200) , ylim=c(10,200) , pch=20 , bg="white" , cex=3+(a/30) , col=rgb(a/300,b/300,0.9,0.9) )
abline(h=c(0,50,100,150) , v=c(0,50,100,150) , col="whitesmoke")
dev.off()


#!/usr/bin/env Rscript
args = commandArgs(trailingOnly=TRUE)

library(edgeR)

files <- c(args[1],args[2],args[3],args[4],args[5],args[6])
class <- c("test", "test", "test", "cont", "cont", "cont")
label <- c("HD1", "HD2", "HD3", "WD1", "WD2", "WD3")

counts <- readDGE(files=files, group=class, labels=label)

noint = rownames(counts) %in% c("no_feature", "ambiguous", "too_low_aQual", "not_aligned", "alignment_not_unique")
cpms =cpm(counts)
keep = rowSums(cpms>1) >=2 & !noint ###############################################################note here: count needs to be one in atleast 2 samples
counts = counts [keep,]

d = DGEList (counts=counts, group=class)
d= calcNormFactors (d)

plotMDS (d, labels=label, col=c("darkgreen", "blue") [factor(class)])

d= estimateCommonDisp(d)
d=estimateTagwiseDisp(d)

plotMeanVar(d, show.tagwise.vars=TRUE, NBline=TRUE)
plotBCV(d)

de = exactTest(d, pair=c("test", "cont"))
tt= topTags (de, n=nrow(d))
nc  =  cpm(d, normalized.lib.sizes = TRUE)
rn  =  rownames(tt$table)

head(nc[rn,order(class)],5)

deg  =  rn[tt$table$FDR  <  .05]
plotSmear(d, de.tags = deg)

write.csv(tt$table, file =  "toptags_edgeR.csv" )
write.csv(nc, file =  "reads" )


#!/usr/bin/env Rscript

args<-commandArgs(TRUE)
input = args[1]
treatment = args[2]
output = paste(input,'.',treatment,'.pdf',sep='')

pdf(output,width=10,height=10)
dat <- as.matrix(read.table(input, header = TRUE))
title = gsub("_", " ", paste(treatment, "-", "Dinucleotide Frequencies"))
positionLength = length(dat[1,])
colors = rev(c("#a1dab4",
               "#41b6c4",
               "#2c7fb8",
               "#253494"))
colors16 = c("#a6cee3",
              "#1f78b4",
              "#b2df8a",
              "#33a02c",
              "#fb9a99",
              "#e31a1c",
              "#fdbf6f",
              "#ff7f00",
              "#cab2d6",
              "#6a3d9a",
              "#000000",
              "#b15928",
              "#555577",
              "#036d24",
              "#cb2f2a",
              "#972acb")
#library(RColorBrewer)
#colors = rev(brewer.pal(6,"Blues"))[1:4]

# Get frequencies
for (i in 1:positionLength){
  dat[,i] = dat[,i]/sum(dat[,i])
}

par(fig=c(0.1,0.95,0.1,0.95))
plot(NA, xlim=c(1,positionLength), NA,  ylim=c(0,1), main=title, bty='n', xlab='Position', ylab='Frequency')

for (i in 1:length(dat[,1])){
  points(1:positionLength, as.list(dat[i,]),
         type="b",
         lty=i,
         pch=i,
         col=colors16[i],
         bg = colors16[i])
}

par(fig=c(0.7,0.9,0.1,0.95), new=TRUE)

legend( x="topright",
        legend=row.names(dat),
        col=colors16, lwd=1, lty=c(1,16),
        pch=c(1:16), bty = 'n', cex= 1)

dev.off()


#!/usr/bin/env Rscript
# From https://github.com/berkeley-dsep-infra/datahub/issues/814
#      https://github.com/berkeley-dsep-infra/datahub/issues/897

source("/tmp/class-libs.R")

class_name = "IA C188"
class_libs = c(
    "rdd", "0.57",
    "stargazer", "5.2.2",
    "lm.beta", "1.5-1",
    "multcomp", "1.4-8",
    "lfe", "2.8-2"
)

class_libs_install_version(class_name, class_libs)


#set Acclimation Response Ratio for terrestrial and marine organisms
# from Gunderson and Stillman model-averaged results (Gunderson pers. comm.)
ARRland <- 0.11
ARRoce <- 0.24

dT <- seq(-5,5)
dTmaxPerfect <- dT
dTmaxOce <- dT*ARRoce
dTmaxLand <- dT*ARRland

quartz(width=4, height=4)
# png(width=4, height=4, units='in', res=300, file='figures/acclimation_diagram.png')
par(mai=c(1,1,0.2, 0.2), las=1)
plot(dT, dTmaxPerfect, type='l', lwd=2, lty=2, xlab='Change in temperature (°C)', ylab='Change in Tmax (°C)')
lines(dT, dTmaxOce, col='#1f78b4', lwd=5)
lines(dT, dTmaxLand, col='#33a02c', lwd=5)

dev.off()


# Elvis Sun
# 250696535
# Feb 8th

#function params

dcfFunc <- function(
  currentRevenue, currentCapitalSpending, currentDepreciation, taxRateIncome,
  bookValueDebt, bookValueEquity, nolCarriedForward, publiclyTradedFlag,     #8
  lastTradedPrice, numberSharesOutstanding, marketValueDebt, debtCapitalRatio,
  costEquity, betaStock, riskFreeRate, riskPremium,   #16
  costDebt, growthRateStablePeriod, operatingExpenseStablePeriod, workingCapitalStablePeriod,   #20
  betaStablePeriod, debtRatioStablePeriod, costDebtFlag, costDebtStablePeriod,   #24
  capitalExpendituresStablePeriod, growthRateRevenueRng, #26
  operatingExpenseRng, growthRateCapitalSpendingRng,
  growthRateDepreciationRng, workingCapitalRng,  #30
  excessReturnPeriods = 10, capPeriods = 5, output = 1
){

  #transpose if horizontal, and raise an error
  if (nrow(growthRateRevenueRng) == 1){
    growthRateRevenueRng <- t(growthRateRevenueRng)
  }
  if (nrow(growthRateRevenueRng) != excessReturnPeriods){
    stop("Different Dimension Than Excess Return Periods")
  }

  if (nrow(operatingExpenseRng) == 1){
    operatingExpenseRng <- t(operatingExpenseRng)
  }
  if (nrow(operatingExpenseRng) != excessReturnPeriods){
    stop("Different Dimension Than Excess Return Periods")
  }

  if (nrow(growthRateCapitalSpendingRng) == 1){
    growthRateCapitalSpendingRng <- t(growthRateCapitalSpendingRng)
  }
  if (nrow(growthRateCapitalSpendingRng) != excessReturnPeriods){
    stop("Different Dimension Than Excess Return Periods")
  }

  if (nrow(growthRateDepreciationRng) == 1){
    growthRateDepreciationRng <- t(growthRateDepreciationRng)
  }
  if (nrow(growthRateDepreciationRng) != excessReturnPeriods){
    stop("Different Dimension Than Excess Return Periods")
  }

  if (nrow(workingCapitalRng) == 1){
    workingCapitalRng <- t(workingCapitalRng)
  }
  if (nrow(workingCapitalRng) != excessReturnPeriods){
    stop("Different Dimension Than Excess Return Periods")
  }

  #rename variables
  growthRateRevenueVector <- growthRateRevenueRng
  operatingExpenseVector <- operatingExpenseRng
  growthRateCapitalSpendingVector <- growthRateCapitalSpendingRng
  growthRateDepreciationVector <- growthRateDepreciationRng
  workingCapitalVector <- workingCapitalRng

  #if else to calculate some constant
  costEquityVal <- riskFreeRate + betaStock * riskPremium
  if (costEquity != 0 ){
    costEquityVal <- costEquity
  }

  temp <- 1 - debtCapitalRatio
  if (debtCapitalRatio == 0){
    temp <- 1 - bookValueDebt
  }
  equityDebtRatio <- temp
  if (publiclyTradedFlag) {
    equityDebtRatio <- lastTradedPrice * numberSharesOutstanding / (marketValueDebt + lastTradedPrice * numberSharesOutstanding)
  }

  #calculate more constant
  afterTaxCostDebt <- costDebt * (1 - taxRateIncome)
  debtCapitalVal <- 1 - equityDebtRatio
  costCapitalVal <- costEquityVal * equityDebtRatio + afterTaxCostDebt * debtCapitalVal

  #make matrix
  temp <- matrix(, nrow = 33, ncol = excessReturnPeriods + 1)

  for(j in 1:excessReturnPeriods) {
    temp[1,j] <- j

    ifelse(j > 1, temp[2,j] <- temp[2,j-1], temp[2,j] <- currentRevenue * (1 + growthRateRevenueVector[j,1]))
    temp[3,j] <- temp[2,j] * operatingExpenseVector[j,1]
    temp[4,j] <- temp[2,j] - temp[3,j]

    if(j > 1) {
      temp[5,j] <- ifelse(temp[4,j] > 0, ifelse(temp[12,j-1] > temp[4,j], 0, (temp[4,j] - temp[12,j-1])) * taxRateIncome, 0)
      temp[7,j] <- temp[7,j-1] * (1 + growthRateDepreciationVector[j,1])
      temp[8,j] <- temp[8,j-1] * (1 + growthRateCapitalSpendingVector[j,1])
      temp[9,j] <- (temp[2,j] - temp [2,j-1]) * workingCapitalVector[j,1]
      temp[12,j] <- ifelse(temp[12,j-1] > temp[4,j], temp[12,j-1] - temp[4,j], 0)
    }
    else {
      temp[5,j] <- ifelse(temp[4,j] > 0, ifelse(nolCarriedForward > temp[4,j], 0, (temp[4,j] - nolCarriedForward) * taxRateIncome), 0)
      temp[7,j] <- currentDepreciation * (1 + growthRateDepreciationVector[j,1])
      temp[8,j] <- currentCapitalSpending * (1 + growthRateCapitalSpendingVector[j,1])
      temp[9,j] <- (temp[2,j] - currentRevenue) * workingCapitalVector[j,1]
      temp[12,j] <- ifelse(nolCarriedForward > 0, ifelse(nolCarriedForward < temp[2,j], 0, nolCarriedForward - temp[2,j]), 0)
    }

    temp[6,j] <- temp[4,j] - temp[5,j]
    temp[10,j] <- temp[6,j] + temp[7,j] + temp[8,j] - temp[9,j]
    temp[13,j] <- temp[5,j] / temp[4,j]

    if(j <= capPeriods) {
      temp[14,j] <- betaStock
      temp[17,j] <- debtCapitalVal
    }
    else {
      temp[14,j] <- ifelse(betaStablePeriod != 0, temp[14,capPeriods] - ((temp[14,capPeriods] - betaStablePeriod) / capPeriods) * (j - capPeriods), betaStock)
      temp[17,j] <- ifelse(debtRatioStablePeriod != 0, temp[17,capPeriods] - ((temp[17,capPeriods] - debtCapitalVal) / capPeriods) * (j - capPeriods), debtCapitalVal)
    }

    temp[15,j] <- ifelse(costEquity == 0, riskFreeRate + temp[14,j] * riskPremium, costEquity)
    temp[16,j] <- costDebtStablePeriod * (1 - taxRateIncome)
    temp[18,j] <- temp[15,j] * (1 - temp[17,j]) + temp[16,j] * temp[17,j]
    ifelse(j > 1, temp[19,j] <- temp[19,j-1] * (1 + temp[18,j]), temp[19,j] <- 1 + temp[18,j])
    temp[11,j] <- temp[10,j] / temp[19,j]
    ifelse(is.na(temp[28,1]), temp[28,1] <- temp[11,j], temp[28,1] <- temp[28,1] + temp[11,j])
  }

  #temp[1,excessReturnPeriods+1] <- "TN"
  temp[2,excessReturnPeriods+1] <- temp[2,excessReturnPeriods] * (1+ growthRateStablePeriod)
  temp[3,excessReturnPeriods+1] <- temp[2,excessReturnPeriods+1] * operatingExpenseStablePeriod
  temp[4,excessReturnPeriods+1] <- temp[2,excessReturnPeriods+1] - temp[3,excessReturnPeriods+1]
  temp[5,excessReturnPeriods+1] <- ifelse(temp[4,excessReturnPeriods+1] > 0, ifelse(temp[12,excessReturnPeriods] > temp[4,excessReturnPeriods+1], 0, (temp[4,excessReturnPeriods+1] - temp[12,excessReturnPeriods]) * taxRateIncome), 0)
  temp[6,excessReturnPeriods+1] <- temp[4,excessReturnPeriods+1] - temp[5,excessReturnPeriods+1]
  temp[7,excessReturnPeriods+1] <- temp[7,excessReturnPeriods]
  temp[8,excessReturnPeriods+1] <- ifelse(capitalExpendituresStablePeriod == 0, temp[7,excessReturnPeriods+1], temp[7,excessReturnPeriods+1] * capitalExpendituresStablePeriod)
  temp[9,excessReturnPeriods+1] <- (temp[2,excessReturnPeriods+1] - temp[2,excessReturnPeriods]) * workingCapitalStablePeriod
  temp[10,excessReturnPeriods+1] <- temp[6,excessReturnPeriods+1] + temp[7,excessReturnPeriods+1] - temp[8,excessReturnPeriods+1] - temp[9,excessReturnPeriods+1]
  temp[13,excessReturnPeriods+1] <- temp[5,excessReturnPeriods+1] / temp[4,excessReturnPeriods+1]
  temp[14,excessReturnPeriods+1] <- temp[14,excessReturnPeriods]
  temp[15,excessReturnPeriods+1] <- ifelse(costEquity == 0, riskFreeRate + temp[14,excessReturnPeriods+1] * riskPremium, costEquity)
  temp[16,excessReturnPeriods+1] <- temp[16,excessReturnPeriods]
  temp[17,excessReturnPeriods+1] <- temp[17,excessReturnPeriods]
  temp[18,excessReturnPeriods+1] <- temp[15,excessReturnPeriods+1] * (1 - temp[17,excessReturnPeriods+1]) + temp[16,excessReturnPeriods+1] * temp[17,excessReturnPeriods+1]
  temp[20,1] <- growthRateStablePeriod
  temp[21,1] <-temp[10,excessReturnPeriods+1]
  temp[22,1] <- ifelse(betaStablePeriod == 0, riskFreeRate + betaStock * riskPremium, riskFreeRate + betaStablePeriod * riskPremium)
  temp[23,1] <- ifelse(debtRatioStablePeriod != 0, 1 - debtRatioStablePeriod, equityDebtRatio)
  temp[24,1] <- ifelse(costDebtFlag == TRUE, costDebtStablePeriod * (1 - taxRateIncome), afterTaxCostDebt)
  temp[25,1] <- 1 - temp[23,1]
  temp[26,1] <- temp[22,1] * temp[23,1] + temp[24,1] * temp[25,1]
  temp[27,1] <- temp[21,1] / (temp[26,1] - temp[20,1])
  temp[29,1] <- temp[27,1] / temp[19,excessReturnPeriods]
  temp[30,1] <- temp[28,1] + temp[29,1]
  temp[31,1] <- ifelse(publiclyTradedFlag == TRUE, marketValueDebt, bookValueDebt)
  temp[32,1] <- temp[30,1] - temp[31,1]
  temp[33,1] <- temp[32,1] / numberSharesOutstanding

  intrinsicValueShare <- temp[33,1]

  if(output == 0) {
    intrinsicValueShare
  }
  else if(output == 1) {
    temp
  }
}

dcfFunc(108249, 7696, 1814, 0.242157579,
        0.1, 76615, 200000, TRUE, #8
        500, 929.3, 0.1, 0,       #12
        0.07, 1, 0.02, 0.05,      #16
        0.025, 0.03, 0.8165, 0.01,#20
        1, 0.15, TRUE, 0.08,      #24
        1.1,
        matrix(c(rep(0.06,7),rep(0.03,13)),ncol=1),
        matrix(c(rep(0.82,20)),ncol=1),
        matrix(c(0.02,rep(0.06,4),rep(0.03,15)),ncol=1),
        matrix(c(-0.07,rep(0.06,5),rep(0.03,14)),ncol=1),
        matrix(c(rep(0.05,20)),ncol=1),
        20,5,0
)


rangeExpand <- function(text) {
	x <- unlist(strsplit(text, ","))		# split the string on commas
	x <- gsub("(\\d)-", "\\1:", x)			# substitute dashes following a digit with a colon
	lst <- list(mode = "list", length = length(x))	# an empty list to hold evaluated elements
	for (i in 1:length(x)) {			# evaluate each element and add to the list
		lst[[i]] <- eval(parse(text = x[i]))
	}
	unlist(lst, use.names = FALSE)			# return the expanded integers
}