Coordination of Contrariety and Ambiguity in Comparative Compositional Contexts: Balance of Normalized Definitive Status in Multi-indicator Systems

Abstract

We address oppositional aspects of comparative compositional contexts for some particular purpose. Compositional components of land cover in localities provide our context, with the exemplifying purpose being cooperative conservation. A subset of cover components is considered definitely propitious (pro) for the purpose, with another subset being definitely contraindicative (con), and the rest as ambiguous “other.” Plotting percent pro on the ordinate and percent con on the abscissa gives a “definitive domain display” for visualization. A “Balance Of Normalized Definitive Status” (BONDS) is used for scalar sequencing. Using concepts of “down-set” and “up-set” from theory of partially ordered sets (posets), this is extended to obtain an intrinsically compositional context of pro and con that applies objectively to any suite of (monotonic) indicators. Indicators are eliminated in a systematic manner to resolve ties in the extended version by lexicographic suborder. Computations are specified in terms of R software.

Appendices

Appendix 1: R Procon Function to Partition Compositional Components

Procon <- function(PctTabl,Id,Pros,Cons)

# This function is for composition indicators as %.

# Id is column number of case ID.

# Pros is vector of column numbers as Pros.

# Cons is vector of column numbers as Cons.

{Ids <- PctTabl[,Id]

Npro <- length(Pros)

Ncon <- length(Cons)

Itms <-length(Ids)

Pro <- rep(0.0,Itms)

Con <- rep(0.0,Itms)

for(I in 1:Itms)

{for(J in 1:Npro)

{K <- Pros[J]

Pro[I] <- Pro[I] + PctTabl[I,K]

}

for(J in 1:Ncon)

{K <- Cons[J]

Con[I] <- Con[I] + PctTabl[I,K]

}

}

ProCon <- cbind(Ids,Pro,Con)

ProCon

}

Appendix 2: R Proconplot Function for Definitive Domain Display

ProconPlot <- function(PpCc,Capital=1)

# Input is pro and con data frame.

# Idz is column number of CaseIDs.

# Pp is column number of Pro part.

# Cc is column number of Con component.

{Cases <- length(PpCc[,1])

Idz <- 1

Pp <- 2

Cc <- 3

Ymax <- max(PpCc[,Pp])

Ymin <- min(PpCc[,Pp])

Xmax <- max(PpCc[,Cc])

Xmin <- min(PpCc[,Cc])

Xright <- Ymax

if(Xmax>Ymax) Xright <- Xmax

if(Capital==1) plot(PpCc[,Cc],PpCc[,Pp],ylab="%Pro",

xlab="%Con",xlim=c(0,Xright))

if(Capital>1) plot(PpCc[,Cc],PpCc[,Pp],ylab="%PRO",

xlab="%CON",xlim=c(0,Xright))

YY <- c(Ymax,Ymin)

XX <- c(100-Ymax,100-Ymin)

lines(XX,YY,lty=1)

XX <- c(Xmin,Xmin)

YY <- c(Ymin,Ymax)

lines(XX,YY,lty=2)

XX <- c(Xmin,Ymax)

if(Xmax>Ymax) XX <- c(Xmin,Xmax)

YY <- c(Ymin,Ymin)

lines(XX,YY,lty=2)

XX <- c(Xmin,100-Ymax)

YY <- c(Ymax,Ymax)

lines(XX,YY,lty=2)

for(I in 1:Cases)

{IPp <- PpCc[I,2]

ICc <- PpCc[I,3]

Frq <- 0

for(J in 1:Cases)

{JPp <- PpCc[J,2]

JCc <- PpCc[J,3]

if(IPp==JPp & ICc==JCc) Frq <- Frq + 1

}

if(Frq>1) points(ICc,IPp,pch="+")

}

}

Appendix 3: R BONDings Function for Calculating BONDS Values and BONDSranks

BONDings <- function(ProAnCon,Items=1)

# This function takes output of Procon or POprocon.

# Appends Balance Of Normalized Definite Status (BONDS) and BONDSrank.

# Items=2 gives both BONDS values and BONDSranks.

{ID <- ProAnCon[,1]

Pro <- ProAnCon[,2]

Con <- ProAnCon[,3]

Ncase <- length(ID)

BONDS <- rep(0,Ncase)

for(I in 1:Ncase)

BONDS[I] <- (Pro[I] - Con[I]) * (Pro[I] + Con[I])/100.0

BONDSrank <- rank(BONDS,ties.method="average")

ProconBOND <- cbind(ProAnCon,BONDS,BONDSrank)

ProconBOND <- ProconBOND[order(ProconBOND[,4]),]

Lo <- -1

Hi <- -1

for(I in 1:Ncase)

{if(ProconBOND[I,2]==ProconBOND[I,3] & Lo<0) Lo <- I

if(ProconBOND[I,2]==ProconBOND[I,3]) Hi <- I

}

Zros <- 0

if(Lo>0) Zros <- Hi - Lo + 1

if(Zros>0)

{Zrows <- rep(0,Zros)

for(I in 1:Zros)

{J <- Lo + I - 1

Zrows[I] <- ProconBOND[J,2]

}

Zrows <- rank(Zrows,ties.method="average")

for(I in 1:Zros)

{J <- Lo + I - 1

ProconBOND[J,5] <- Zrows[I] + Lo - 1

}

}

ProconBOND <- ProconBOND[order(ProconBOND[,1]),]

if(Items<2) ProconBOND <- ProconBOND[,-4]

ProconBOND

}

Appendix 4: R Pickind Function for Selecting and Orienting Indicators

Pickind <- function(Aframe,IDitem,Pickings)

# This function takes data frame of general indicators.

# IDitem is column number of case ID.

# Pickings is vector of column numbers of indicators.

# Negative column number negates column as cons.

{Items <- length(Aframe)

IDs <- Aframe[,IDitem]

INcas <- length(IDs)

Picks <- length(Pickings)

Kindups <- Aframe

Xitems <- 0

for(I in 1:Picks)

{J <- Pickings[I]

if(J<0)

{J <- -1 * J

Kindups[,J] <- -1 * Kindups[,J]

}

}

for(I in 1:Items)

{K <- Items - I + 1

Xitem <- 1

for(J in 1:Picks)

{KK <- Pickings[J]

if(KK<0) KK <- -1 * KK

if(KK == K) Xitem <- 0

}

Xitems <- Xitems + Xitem

if(Xitem>0) Kindups <- Kindups[,-K]

}

Kindups <- cbind(IDs,Kindups)

Kindups

}

Appendix 5: R POprocon Function for Product-Order Comparative Compilation

POprocon <- function(Rating)

# Function takes output of Pickind as input.

{CaseIDs <- Rating[,1]

Ratings <- Rating[,-1]

Ncase <- length(CaseIDs)

Ncol <- length(Ratings)

DD <- Ncase - 1

Status1 <- rep(-1,Ncase)

Status2 <- Status1

for(I in 1:Ncase)

{Nosub <- 0; Levl <- 0

for(J in 1:Ncase)

{if(I<J | I>J)

{MatchA <- 0; MatchB <- 0; Undom <- 1

VecA <- Ratings[I,] - Ratings[J,]

if(max(VecA) > 0) MatchA <- 1

if(min(VecA) < 0) MatchB <- 1

if(MatchA==1 & MatchB==0) Nosub <- Nosub + 1

if(MatchA==0 & MatchB==1) Undom <- 0

Levl <- Levl + Undom

}

}

Status1[I] <- Nosub

Status2[I] <- DD - Levl

}

Pct <- 100.0/DD

PRO <- round((Status1 * Pct),digits=2)

CON <- round((Status2 * Pct),digits=2)

POpropensity <- cbind(CaseIDs,PRO,CON)

POpropensity

}

Appendix 6: R TieSpecs Program for Membership of Instances in Tied Sets

TieSpecs <- function(Rating)

# Function takes extended output of BONDings as input.

{Ncase <- length(Rating[,1])

Status1 <- Rating[,2]

Status2 <- Rating[,3]

TieSets <- rep(0,Ncase)

TieLink <- TieSets

TopTie <- 1

for(I in 1:Ncase)

{Ties <- 0

for(J in 1:Ncase)

{if(I<J | I>J)

{if(Status1[I]==Status1[J] & Status2[I]==Status2[J] & TieSets[J]<1)

{Ties <- Ties+1

TieSets[J] <- TopTie

}

}

}

if(Ties>0)

{TieSets[I] <- TopTie

TopTie <- TopTie + 1

}

}

TopTie <- TopTie - 1

if(TopTie > 0)

{for(I in 1:Ncase)

{TieTo <- 0

if(TieSets[I]>0 & I<Ncase)

{TieSet <- TieSets[I]

II <- I + 1

for(J in II:Ncase)

if(TieSets[J]==TieSet & TieTo==0) TieTo <- J

}

TieLink[I] <- TieTo

}

}

LexIndx <- Rating[,5]

if(TopTie>0)

{ccc <- rank(LexIndx,ties.method="first")

for(I in 1:TopTie)

{TieLo <- Ncase

for(J in 1:Ncase)

{if(TieSets[J]==I & ccc[J]<TieLo) TieLo <- ccc[J]

if(TieSets[J]==I & TieLink[J]==0) TieLink[J] <- -1 * (TieLo-1)

}

}

}

POpropensity <- cbind(Rating,TieSets,TieLink)

POpropensity

}

Appendix 7: R TIEphasA Function for Dropping Indicators to Break Ties

TIEphasA <- function(Ratings,Lexings,KeepOrdr,SepraSet)

# Ratings is output of Pickind.

# Lexings is output of TieSpecs.

# KeepOrdr is retention priority order for ratings.

# SepraSet is TieSets number in Lexings.

{Ncase <- length(Lexings[,1])

DD <- Ncase - 1

Inset <- 0

for(I in 1:Ncase)

if(Lexings[I,6]==SepraSet) Inset <- Inset + 1

TieIds <- rep(0,Inset)

TieDex <- 1

for(I in 1:Ncase)

if(Lexings[I,6]==SepraSet)

{TieIds[TieDex] <- Lexings[I,1]

TieDex <- TieDex + 1

}

Keeps <- length(KeepOrdr)

Rated <- length(Ratings) - 1

Outings <- Keeps * Inset

Status1 <- rep(-1,Outings)

Status2 <- rep(-1,Outings)

IDti <- rep(0,Outings)

Step <- rep(0,Outings)

Outdex <- 0

# Drop cycle

Keeping <- Keeps

Instep <- 0

for(M in 1:Keeps)

{VecA <- rep(0,Keeping)

VecB <- rep(0,Keeping)

for(II in 1:Inset)

{I <- TieIds[II]

Nosub <- 0; Levl <- 0

for(K in 1:Keeping)

{KK <- KeepOrdr[K] + 1

VecA[K] <- Ratings[I,KK]

}

for(J in 1:Ncase)

{for(K in 1:Keeping)

{KK <- KeepOrdr[K]+1

VecB[K] <- Ratings[J,KK]

}

if(I<J | I>J)

{MatchA <- 0; MatchB <- 0; Undom <- 1

VecB <- VecA - VecB

if(max(VecB) > 0) MatchA <- 1

if(min(VecB) < 0) MatchB <- 1

if(MatchA==1 & MatchB==0) Nosub <- Nosub + 1

if(MatchA==0 & MatchB==1) Undom <- 0

Levl <- Levl + Undom

}

}

Outdex <- Outdex + 1

Status1[Outdex] <- Nosub

Status2[Outdex] <- DD - Levl

Step[Outdex] <- Instep

IDti[Outdex] <- I

}

Keeping <- Keeping - 1

Instep <- Instep - 1

}

Pct <- 100.0/DD

Pro <- round((Status1 * Pct),digits=2)

Con <- round((Status2 * Pct),digits=2)

TIEBONDS <- rep(0,Outings)

for(I in 1:Outings)

TIEBONDS[I] <- (Pro[I] - Con[I]) * (Pro[I] + Con[I])/100.0

Untidrop <- cbind(Step,IDti,Pro,Con,TIEBONDS)

Untidrop

}

Appendix 8: R TIEphasB Function for Breaking Ties with Individual Indicators

TIEphasB <- function(Ratings,Lexings,KeepOrdr,SepraSet)

# Ratings is output of Pickind.

# Lexings is output of TieSpecs.

# KeepOrdr is priority order for ratings.

# SepraSet is TieSets number in Lexings.

{Ncase <- length(Lexings[,1])

DD <- Ncase - 1

Inset <- 0

for(I in 1:Ncase)

if(Lexings[I,6]==SepraSet) Inset <- Inset + 1

TieIds <- rep(0,Inset)

TieDex <- 1

for(I in 1:Ncase)

if(Lexings[I,6]==SepraSet)

{TieIds[TieDex] <- Lexings[I,1]

TieDex <- TieDex + 1

}

Keeps <- length(KeepOrdr)

Rated <- length(Ratings) - 1

Outings <- Keeps * Inset

Status1 <- rep(-1,Outings)

Status2 <- rep(-1,Outings)

IDti <- rep(0,Outings)

Step <- rep(0,Outings)

Outdex <- 0

# Singular cycle

Keeping <- 1

Instep <- 1

for(M in 1:Keeps)

{for(II in 1:Inset)

{I <- TieIds[II]

Nosub <- 0; Levl <- 0

K <- Keeping

KK <- KeepOrdr[K] + 1

VecA <- Ratings[I,KK]

for(J in 1:Ncase)

{K <- Keeping

KK <- KeepOrdr[K]+1

VecB <- Ratings[J,KK]

if(I<J | I>J)

{MatchA <- 0; MatchB <- 0; Undom <- 1

VecB <- VecA - VecB

if(VecB > 0) MatchA <- 1

if(VecB < 0) MatchB <- 1

if(MatchA==1 & MatchB==0) Nosub <- Nosub + 1

if(MatchA==0 & MatchB==1) Undom <- 0

Levl <- Levl + Undom

}

}

Outdex <- Outdex + 1

Status1[Outdex] <- Nosub

Status2[Outdex] <- DD - Levl

Step[Outdex] <- Instep

IDti[Outdex] <- I

}

Keeping <- Keeping + 1

Instep <- Instep + 1

}

Pct <- 100.0/DD

Pro <- round((Status1 * Pct),digits=2)

Con <- round((Status2 * Pct),digits=2)

TIEBONDS <- rep(0,Outings)

for(I in 1:Outings)

TIEBONDS[I] <- (Pro[I] - Con[I]) * (Pro[I] + Con[I])/100.0

Unti1x1 <- cbind(Step,IDti,Pro,Con,TIEBONDS)

Unti1x1

}

Appendix 9: R TIEphasC Function for Assigning Ranks Among Ties

TIEphasC <- function(Lexings,Untidrop,Unti1x1,SepraSet)

# Tie Resolving Indicator Modification ranks

# Lexings is output of TieSpecs

# Untidrop is output of TIEphasA

# Unti1x1 is output of TIEphasB

# SepraSet is TieSets number in Lexings

{Ncase <- length(Lexings[,1])

Inset <- 0

SubTie <- 0

for(I in 1:Ncase)

{if(Lexings[I,6]==SepraSet) Inset <- Inset + 1

if(Lexings[I,6]==SepraSet & Lexings[I,7]<0) SubTie <- -1 * Lexings[I,7]

}

TieIds <- rep(0,Inset)

TieDex <- 1

for(I in 1:Ncase)

if(Lexings[I,6]==SepraSet)

{TieIds[TieDex] <- Lexings[I,1]

TieDex <- TieDex + 1

}

Unties <- rbind(Untidrop,Unti1x1)

Outings <- length(Unties[,1])

TRIMrank <- rep(0,Inset)

LexRnk <- rep(0,Inset)

for(I in 1:Inset) LexRnk[I] <- SubTie + I

Instep <- rep(0,Inset)

Idone <- 0

Ilo <- 1

Ihi <- Inset

Nleft <- Inset

while(Idone < 1)

{Lexleft <- rep(0,Nleft)

StepLex <- rep(0,Nleft)

StepRank <- rep(0,Nleft)

J <- 1

for(I in 1:Inset)

if(TRIMrank[I]==0) {Lexleft[J] <- I;J <- J + 1}

J <- 1

K <- Ilo

for(I in 1:Inset)

if(TRIMrank[I]==0)

{StepLex[J] <- Unties[K,5]

J <- J + 1

K <- K + 1

}

StepRank <- rank(StepLex,ties.method="average")

for(I in 1:Nleft)

{Tied <- 0

for(J in 1:Nleft)

if(I != J & StepRank[I]==StepRank[J]) Tied <- 1

if(Tied==0)

{K <- Lexleft[I]

KK <- StepRank[I]

TRIMrank[K] <- LexRnk[KK]

LexRnk[KK] <- 0

Instep[K] <- Unties[Ilo,1]

}

}

Nleft <- 0

KK <- 0

for(K in 1:Inset)

if(LexRnk[K]>0) Nleft <- Nleft + 1

if(Nleft>0)

{for(K in 1:Inset)

{if(LexRnk[K]>0)

{KK <- KK +1

LexRnk[KK] <- LexRnk[K]

}

}

if(KK<Inset)

{KK <- KK + 1

for(K in KK:Inset) LexRnk[K] <- 0

}

}

if(Nleft==0) Idone <- 1

Ilo <- Ilo + Inset

Ihi <- Ihi + Inset

if(Ihi>Outings) Idone <- 1

}

LexdSet <- cbind(TieIds,TRIMrank,Instep)

LexdSet

}