### Defines functions for calculation of the POII #################################################

  ### Date: 7/25/2016

  ### Description: 
  ### Functions to calculate POII, CHDI, Comparability, Dominance, etc.

  ### Functions:
  ### podi(data,groups=NULL,subgroups=NULL,measures=NULL,weights=NULL)
  ### bootrank.podi(data,groups,measures=NULL,replications=5,onesample=TRUE,weights=NULL,verbose=T,alpha=0.05) 
  ### print.podi(x)
  ### summary.podi(x)
  ### predict.podi(x)
  ### chdi.podi(x)
  ### comparability.podi(x)
  ### dominance.podi(x)
  ### ranking.podi(x)
  ### decomposition.podi(x)
  ### plot.bootpoi(x,...)


### Load libraries ################################################################################

  library(compiler)
  library(Matrix)
  library(plyr)


### Main function #################################################################################

  # Usage: 
  # podi(data,groups,subgroups=NULL,measures=NULL)

  # Arguments:
  # data (data.frame or matrix)   = data.frame/matrix which includes all groups and measures
  # groups (character)            = Name of variable in "data" which indicates groups given as character
  # subgroups (character)         = Name of variable in "data" which indicates subgroups used for decomposition given as character
  # measures (character)          =  Specifies names of variables which capture conditions given as character vector. If not specified, all variables minus "groups" and "subgroups"
  #                                  will be assumed to capture conditions. Conditions are assumed to be coded binary.
  # weights (character)           = Name of variable with sampling weights

  # Value:
  # Returns an object of class 'podi'

  podi <- function(data,groups,subgroups=NULL,measures=NULL,weights=NULL) {
    
    # Basic checks: Right format of arguments
    
      if(!is.data.frame(data)&!is.matrix(data)) stop("'data' is not a data.frame or matrix") 
      if(!is.character(groups)|length(groups)!=1|!groups%in%names(data)) stop("'groups' is not valid")
      if(!is.null(subgroups)) if(!is.character(subgroups)|length(subgroups)!=1|!subgroups%in%names(data)) stop("'subgroups' is not valid")
      if(!is.null(weights)) if(!is.character(weights)|length(weights)!=1|!weights%in%names(data)) stop("'weights' is not valid")
      if(!is.null(measures)) if(!is.character(measures)) stop("'measures' is not valid")

    # Check: If subgroup decomposition only two groups allowed
    
      if(!is.null(subgroups)&length(unique(data[,groups]))>2) stop("Decomposition only allowed with two groups")
    
    # Get/check variables
    
      if(is.null(measures)) {
        measures <- names(data)[-which(names(data)%in%c(groups,subgroups,weights))]
      } else {
        if(!all(measures%in%names(data))) stop("'measures' contains invalid entries")
      }
    
    # Get subset of data
    
      data <- subset(data,select=c(groups,subgroups,measures,weights))
    
    # Get set of unique conditions
      
      combinations <- unique(data[,measures])
    
    # Check whether all measures are binary or not
      
      if(!all(apply(combinations,2,function(x) all(unique(x)%in%c(0,1))))) stop("'measures' are not binary")
  
    # Build dominance/comparability structure using sparse matrices
      
      product <- Matrix(as.matrix(combinations))%*%t(Matrix(as.matrix(combinations)))
      level <- Matrix(data=rep(rowSums(combinations),dim(combinations)[1]),byrow=T,ncol=dim(combinations)[1],sparse=T)
      dominance <- product==level
      diag(dominance) <- FALSE
      comparability <- product==level|product==t(level)
      dcomparability <- comparability
      dcomparability[which(rowSums(combinations)%in%c(0,length(measures))),] <- FALSE
      dcomparability[,which(rowSums(combinations)%in%c(0,length(measures)))] <- FALSE
    
    # Cycle through groups to get comparability and dominance 
      
      # Get groups
      dgroups <- unique(data[,groups])
      
      # Get subgroups
      if(!is.null(subgroups)) sgroups <- unique(data[,subgroups])
      
      # Cycle through groups
      for(i in dgroups) {
  
        # Get distribution of conditions
        distr <- count(data[data[,groups]==i,],vars=measures,wt_var=weights)
        distr$freq <- distr$freq/sum(distr$freq)
      
        # Merge unique conditions and frequencies
        combinations_order <- rownames(combinations)
        combinations$order <- combinations_order
        combinations <- merge(combinations,distr,all.x=T,sort=F)
        rownames(combinations) <- combinations$order
        combinations <- combinations[combinations_order,]
        #names(combinations)[which(names(combinations)=="Freq")] <- "freq"
        combinations$freq[is.na(combinations$freq)] <- 0
  
        # Calculate comparability
        combinations[,paste("Com",i,sep="_")] <- as.numeric(comparability%*%combinations$freq)
        
        # Calculate conditional comparability
        combinations[,paste("Com2",i,sep="_")] <- as.numeric(dcomparability%*%combinations$freq)
        
        # Calculate dominance
        combinations[,paste("Dom",i,sep="_")] <- as.numeric(dominance%*%combinations$freq)
        
        # Remove frequencies
        combinations <- combinations[,-which(names(combinations)=="freq")]
        
        # Subgroup decompositon
        if(!is.null(subgroups)) {
            
            # Cycle through subgroups
            for(j in sgroups) {
              
              # Get distribution of conditions
              distr <- count(data[data[,groups]==i&data[,subgroups]==j,],vars=measures,wt_var=weights)
              distr$freq <- distr$freq/sum(distr$freq)

              # Merge
              combinations_order <- rownames(combinations)
              combinations$order <- combinations_order
              combinations <- merge(combinations,distr,all.x=T,sort=F)
              rownames(combinations) <- combinations$order
              combinations <- combinations[combinations_order,]
              combinations$freq[is.na(combinations$freq)] <- 0
              
              # Vars for comparability/dominance
              combinations[,paste("Com",i,j,sep="_")] <- as.numeric(comparability%*%combinations$freq)
              combinations[,paste("Dom",i,j,sep="_")] <- as.numeric(dominance%*%combinations$freq)
              
              # Remove frequencies
              combinations <- combinations[,-which(names(combinations)=="freq")]
              
            }
          
        } # End cylce subgroups
        
      } # End cycle groups
    
    # Merge results back to data
      
      data$ids <- rownames(data)
      data <- merge(data,combinations[,-which(names(combinations)=="order")],sort=F)
      rownames(data) <- paste(data$ids)
      data <- data[,-which(names(data)%in%"ids")]
    
    # Remove unnecessary objects
      
      rm(combinations,dominance,comparability,product,level)
    
    # Matrices for results
      
      n <- length(dgroups)
      dominance <- matrix(data=NA,ncol=n,nrow=n)
      rownames(dominance) <- paste(dgroups)
      colnames(dominance) <- paste(dgroups)
      im <- poii <- chdi <- scomparability <- dcomparability <- comparability <- dominance
      if(!is.null(subgroups)) {
        sn <- length(sgroups)
        decom <- matrix(data=NA,ncol=sn*n,nrow=sn*n)
        rownames(decom) <- c(t(outer(dgroups, sgroups, paste,sep="_")))
        colnames(decom) <- c(t(outer(dgroups, sgroups, paste,sep="_")))
      }
    
    # Aggregate: Dominance/Comparability/CHDI
      
      # Cycle through groups
      for(i in dgroups) {
        
        # Dominance
        if(is.null(weights)) tmp <- by(data[,paste("Dom",i,sep="_")],data[,groups],mean) else tmp <- by(data,data[,groups],function(x) weighted.mean(x[,paste("Dom",i,sep="_")],w=x[,weights]))
        dominance[paste(i),names(tmp)] <- as.numeric(tmp)
        
        # Comparability
        if(is.null(weights)) tmp <- by(data[,paste("Com",i,sep="_")],data[,groups],mean) else tmp <- by(data,data[,groups],function(x) weighted.mean(x[,paste("Com",i,sep="_")],w=x[,weights]))
        comparability[paste(i),names(tmp)] <- as.numeric(tmp)
        
        # Decomposed comparability: Comparability among the sick
        scores <- !rowSums(data[,measures])%in%c(0,length(measures))
        scores[scores==0] <- NA
        data$tmpscore <- data[,paste("Com2",i,sep="_")]*scores
        if(is.null(weights)) tmp <- by(data[,"tmpscore"],data[,groups],mean,na.rm=T) else tmp <- by(data,data[,groups],function(x) weighted.mean(x[,"tmpscore"],w=x[,weights],na.rm=T))
        scomparability[paste(i),names(tmp)] <- as.numeric(tmp)
        
        # Weighted dominance
        data[,paste("DomCom",i,sep="_")] <- data[,paste("Dom",i,sep="_")]/data[,paste("Com",i,sep="_")]
        data[,paste("DomCom",i,sep="_")][is.nan(data[,paste("DomCom",i,sep="_")])] <- NA
        if(is.null(weights)) tmp <- by(data[,paste("DomCom",i,sep="_")],data[,groups],mean,na.rm=T) else tmp <- by(data,data[,groups],function(x) weighted.mean(x[,paste("DomCom",i,sep="_")],w=x[,weights],na.rm=T))
        chdi[paste(i),names(tmp)] <- as.numeric(tmp) 
        
        # Weighted dominance by subgroup
        if(!is.null(subgroups)) {
          for(j in sgroups) {
            data[,paste("DomCom",i,j,sep="_")] <- data[,paste("Dom",i,j,sep="_")]/data[,paste("Com",i,j,sep="_")]
            data[,paste("DomCom",i,j,sep="_")][is.nan(data[,paste("DomCom",i,j,sep="_")])] <- NA
            if(is.null(weights)) tmp <- by(data[,paste("DomCom",i,j,sep="_")],list(data[,subgroups],data[,groups]),mean,na.rm=T) else tmp <- by(data,list(data[,subgroups],data[,groups]),function(x) weighted.mean(x[,paste("DomCom",i,j,sep="_")],w=x[,weights],na.rm=T))
            decom[paste(i,j,sep="_"),] <- c(t(tmp[sort(sgroups),sort(dgroups)]))
          }
        }
      }
    
    # Comparability by definition
      
      data$score <- rowSums(data[,measures])
      data$score <- data$score %in% c(0,length(measures))
      if(is.null(weights)) tmp <- as.numeric(by(data$score,data[,groups],mean)[paste(dgroups)]) else tmp <- as.numeric(by(data,data[,groups],function(x) weighted.mean(x[,"score"],w=x[,weights],na.rm=T))[paste(dgroups)])
      tmp2 <- (1-tmp)
      dcomparability <- t(matrix(tmp,ncol=length(dgroups),nrow=length(dgroups)))+matrix(tmp,ncol=1)%*%tmp2
      rownames(dcomparability) <- paste(dgroups)
      colnames(dcomparability) <- paste(dgroups)

    # Calculate PODI
      
      poii <- chdi-t(chdi)
    
    # Index measure
      
      im <- apply(poii,1,mean)
    
    # For prediction
      
      prdat <- data[,-which(names(data)%in%c(groups,subgroups,measures,weights))]
    
    # Weights for decomposition
      
      if(!is.null(subgroups)) {
        d.weights <- (prop.table(table(data[,c(groups,subgroups)]),1))[1,]*(prop.table(table(data[,c(groups,subgroups)]),1))[2,]
      }
    
    # Output results
      
      if(is.null(subgroups)) {
        results <- list("PODI"=poii,"Dominance"=dominance,"Comparability"=comparability,"CHDI"=chdi,"Summary index"=im,"Basic indices"=prdat,"Scomparability"=scomparability,"Dcomparability"=dcomparability)
      } else {
        results <- list("PODI"=poii,"Dominance"=dominance,"Comparability"=comparability,"CHDI"=chdi,"Summary index"=im,"Basic indices"=prdat,"Scomparability"=scomparability,"Dcomparability"=dcomparability,"Decomposition"=decom,"Weights"=d.weights)
      }
      class(results) <- "podi"
    
      return(results)
    
  } # END OF FUNCTION
  
  # Compile function
  
    podi <- cmpfun(podi)

    
### Simple bootstrap wrapper ######################################################################
    
  # Usage: 
  # bootrank.podi(data,groups,measures=NULL,replications,onesample,weights,verbose,alpha)
    
  # Arguments:
  # data (data.frame)       = data.frame/matrix which includes all groups and measures 
  # groups (character)      = variable in "data" which indicates groups given as character 
  # measures (character)    =  Specifies variables which capture conditions given as character vector. If not specified, all variables minus "groups" and "subgroups"
  #                           will be assumed to capture conditions. Conditions are assumed to be coded binary.
  # replications (numeric)  = Number of bootstrap replications
  # onesample (logical)     = Does the data come from one sample? If FALSE,
  #                         resampling is from data by groups
  # weights (numeric)       = Vector of weights to be used for resampling; will be rescaled to sum to one
  # verbose (logical)       = If true, progress of replications will be reported
  # alpha (numeric)         = Alpha level for confidence intervals
    
  # Value:
  # Returns an object of class 'bootpoi'
    
  bootrank.podi <- function(data,groups,measures=NULL,replications=5,onesample=TRUE,weights=NULL,verbose=T,alpha=0.05) {
    
    main <- podi(data=data,groups=groups,measures=measures)[["Summary index"]]
    
    dgroups <- unique(data[,groups])
    indices <- rownames(data)
    n <- dim(data)[1]
    if(!onesample) ns <- table(data[,groups])
    if(is.null(weights)) if(onesample) weights <- rep(1/n,n) else {
      tmpweights <- 1/ns
      weights <- numeric(n)
      for(j in dgroups) {
        weights[data[,groups]==j] <- tmpweights[paste(j)]
      }
    }
    
    results <- matrix(data=NA,ncol=length(dgroups),nrow=replications)
    colnames(results) <- paste(dgroups)
    
    if(verbose) cat("Bootstrap replications: ")
    
    if(onesample) for(i in 1:replications) {
      
      if(verbose) cat(".")
      tmpdat <- data[sample(indices,rep=T,prob=weights),]
      tmp <- podi(data=tmpdat,groups=groups,measures=measures)
      results[i,paste(dgroups)] <- tmp[["Summary index"]][paste(dgroups)]
      
    } else for(i in 1:replications) {
      if(verbose) cat(".")
      
      tmpdat <- data[sample(indices[data[,groups]==dgroups[1]],rep=T,prob=weights[data[,groups]==dgroups[1]]),]
      for(j in 2:length(dgroups)) {
        tmpdat2 <- data[sample(indices[data[,groups]==dgroups[j]],rep=T,prob=weights[data[,groups]==dgroups[j]]),]
        tmpdat <- rbind(tmpdat,tmpdat2)
      }
      
      tmp <- podi(data=tmpdat,groups=groups,measures=measures)
      results[i,paste(dgroups)] <- tmp[["Summary index"]][paste(dgroups)]
    }
    
    bounds <- apply(results,2,quantile,probs=c(alpha/2,1-alpha/2))
    result <- rbind(main[names(main)],bounds[,names(main)])
    rownames(result)[1] <- "Point"
    
    class(result) <- "bootpoi"
    
    return(result)
  }

  # Compile function
    
  bootrank.podi <- cmpfun(bootrank.podi)
    
    
### Helpers #######################################################################################
  
  ### print method for objects of class "podi"
  ### Usage: 
  ### print(x)
  ### Arguments:
  ### x = Object of class "podi" as created by the function podi
    
    print.podi <- function(x) {
      cat("*PODI*","\n")
      print(x[["PODI"]])
    }
  
  ### summary method for objects of class "podi"
  ### Usage:
  ### summary(x)
  ### Arguments:
  ### x = Object of class "podi" as created by the function podi

    summary.podi <- function(x) {
      cat("*PODI*\n\n")
      print(x[["PODI"]])
      cat("\n *Comparability*\n\n")
      print(x[["Comparability"]])
      cat("\n *Summary index*\n\n")
      print(x[["Summary index"]])
      cat("\n *Ranking*\n\n")
      tmp <- matrix(data=c(names(x[["Summary index"]])[order(x[["Summary index"]],decreasing=T)],1:length(x[["Summary index"]])),ncol=2)
      colnames(tmp) <- c("Group","Rank")
      rownames(tmp) <- rep("",length(x[["Summary index"]]))
      print(tmp,quote=F)
    }
  
  ### predict method for objects of class "podi"
  ### Usage:
  ### predict(x)
  ### Arguments:
  ### x = Object of class "podi" as created by the function podi
    
    
    predict.podi <- function(x) {
      return(x[["Basic indices"]])
    }
  
  ### chdi.podi
  ### Returns CHDI from a "podi" object
  ### Usage:
  ### chdi.podi(x)
  ### Arguments:
  ### x = Object of class "podi" as created by the function podi
    
    
    chdi.podi <- function(x) {
      return(x[["CHDI"]])
    }
  
  ### dominance.podi
  ### Returns dominance from a "podi" object
  ### Usage:
  ### dominance.podi(x)
  ### Arguments:
  ### x = Object of class "podi" as created by the function podi
    
    
    dominance.podi <- function(x) {
      return(x[["Dominance"]])
    }
  
  
  ### comparability.podi
  ### Returns comparability from a "podi" object
  ### Usage:
  ### comparability.podi(x)
  ### Arguments:
  ### x = Object of class "podi" as created by the function podi
    
    
    comparability.podi <- function(x) {
      cat("Comparability\n")
      print(x[["Comparability"]])
      cat("\n Decomposed comparability: Comparable by definition\n")
      print(x[["Dcomparability"]])
      cat("\n Decomposed comparability: Comparability among the sick\n")
      print(x[["Scomparability"]])
    }
  
  ### ranking.podi
  ### Returns ranking from a "podi" object
  ### Usage:
  ### ranking.podi(x)
  ### Arguments:
  ### x = Object of class "podi" as created by the function podi
    
    
    ranking.podi <- function(x) {
      cat("Summary index\n")
      print(x[["Summary index"]])
      cat("\n *Ranking*\n\n")
      tmp <- matrix(data=c(names(x[["Summary index"]])[order(x[["Summary index"]],decreasing=T)],1:length(x[["Summary index"]])),ncol=2)
      colnames(tmp) <- c("Group","Rank")
      rownames(tmp) <- rep("",length(x[["Summary index"]]))
      print(tmp,quote=F)
    }
  
  ### decomposition.podi
  ### Returns decomposition from a "podi" object
  ### Usage:
  ### decomposition.podi(x)
  ### Arguments:
  ### x = Object of class "podi" as created by the function podi
    
    
    decomposition.podi <- function(x) {
      tmp <- x[["Decomposition"]]-t(x[["Decomposition"]])
      n <- dim(tmp)[1]
      tmp <- tmp[seq(1,n-1,by=2),]
      tmp <- tmp[,seq(2,n,by=2)]
      groupnames <- unlist(lapply(strsplit(colnames(tmp),split="_"),function(x) x[2]))
      tmp <- diag(tmp)
      names(tmp) <- groupnames
      contr <- tmp*x[["Weights"]][groupnames]
      res <- matrix(c(tmp,x[["Weights"]],contr),nrow=3,byrow=T)
      colnames(res) <- groupnames
      rownames(res) <- c("PODI","Weights","Contribution")
      remainder <- x[["PODI"]][2,1] - sum(contr)
      cat("\n Between subgroups \n",sum(contr),"\n\n Cross-group\n",remainder,"\n\n Total PODI\n",x[["PODI"]][2,1] )
      cat("\n\n Decompositon \n")
      print(res)
    }
    
  ### plot method for objects of class bootpoi
  ### Plots confidence intervals of bootstrap
  ### Usage:
  ### plot(x)
  ### Arguments:
  ### x = Object of class "podi" as created by the function podi
  ### ...= Further arguments passed to dotchart
    
    
    plot.bootpoi <- function(x,...) {
      
      dotchart( x["Point",],xlim=c(min(x)-0.02,max(x)+0.02),...)
      for(i in 1:dim(x)[2]) {
        lines(x=x[2:3,i],y=c(i,i))
      }
      
    }
    
    
### END OF FILE ###################################################################################