Merge pull request #1 from ralmond/working

Working

.gitignore

@@ -0,0 +1,8 @@
+.Rproj.user
+.Rhistory
+.RData
+.Ruserdata
+.Rbuildignore
+*~
+.#*
+inst/doc

ChangeLog

@@ -1,3 +1,10 @@
+2021-03-05  Russell Almond  <ralmond@cherry>
+
+	* R/Tables.R (as.CPA): Issue with R no longer automagically
+	coverting character data to factors.  Decided to fix test case
+	instead of code, as need to distinguish between state markers and
+	other data.
+
 2019-10-27  Rusell Almond  <ralmond@Cherry>
 
 	* R/StackedBars.R (isMonotonic): Added test for monotinicity here,

DESCRIPTION

@@ -1,11 +1,29 @@
 Package: CPTtools
-Version: 0.6-1
-Date: 2019/10/27
 Title: Tools for creating conditional probability tables
+Version: 0.7-2
+Date: 2021/03/05
 Author: Russell Almond
 Maintainer: Russell Almond <[email protected]>
-Depends: R (>= 3.0), lattice, methods
-Description: Provides support for parameterized tables for Bayesian networks .
-License: Artistic-2.0 
+Authors@R: 
+    person(given = "Russell",
+           family = "Almond",
+           role = c("aut", "cre"),
+           email = "[email protected]",
+           comment = c(ORCID = "0000-0002-8876-9337"))
+Description: Provides support parameterized tables for Bayesian
+             networks, particularly the IRT-like DiBello tables.
+             Also, provides some tools for visualing the networks.
+License: Artistic-2.0
+Encoding: UTF-8
+LazyData: true
+Roxygen: list(markdown = TRUE)
+RoxygenNote: 7.1.1
 URL: http://pluto.coe.fsu.edu/RNetica
-
+Depends: methods
+Imports: grDevices, graphics, stats, utils
+Suggests: 
+    ggplot2,
+    lattice,
+    knitr,
+    rmarkdown
+VignetteBuilder: knitr

LICENSE

@@ -0,0 +1,2 @@
+YEAR: 2021
+COPYRIGHT HOLDER: Russell G. Almond

LICENSE.md

@@ -0,0 +1,21 @@
+# MIT License
+
+Copyright (c) 2020 CPTtools
+
+Permission is hereby granted, free of charge, to any person obtaining a copy
+of this software and associated documentation files (the "Software"), to deal
+in the Software without restriction, including without limitation the rights
+to use, copy, modify, merge, publish, distribute, sublicense, and/or sell
+copies of the Software, and to permit persons to whom the Software is
+furnished to do so, subject to the following conditions:
+
+The above copyright notice and this permission notice shall be included in all
+copies or substantial portions of the Software.
+
+THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR
+IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,
+FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE
+AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER
+LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,
+OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE
+SOFTWARE.

NAMESPACE

@@ -1,12 +1,11 @@
-#import(methods)
 
 importFrom("grDevices", "col2rgb", "grey.colors", "hsv", "rgb2hsv")
 importFrom("graphics", "abline", "axis", "barplot", "box", "legend",
            "lines", "mtext", "par", "plot.new", "plot.window", "rect",
            "segments", "text", "title", "xinch", "yinch")
 importFrom("stats", "optim", "pchisq", "pnorm", "qbeta", "qnorm")
 importFrom("utils", "assignInMyNamespace", "read.csv")
-importFrom("lattice", "barchart")
+#importFrom("lattice", "barchart")
 importFrom("methods","is")
 
 export(calcDDTable, calcDDFrame,
@@ -32,14 +31,22 @@ export(rescaleTable, normalizeTable, scaleMatrix,
        normalize.CPA, normalize.default,
        normalize.CPF)
 
+S3method(normalize,data.frame)
+S3method(normalize,array)
+S3method(normalize,matrix)
+S3method(normalize,CPF)
+S3method(normalize,CPA)
+S3method(normalize,default)
+
+
 ## From WOE package
 export(betaci, proflevelci, barchart.CPF,
        stackedBarplot, compareBars, stackedBars, compareBars2,
        colorspread, OCP, OCP2,
        buildFactorTab, build2FactorTab, buildMarginTab,
        marginTab,parseProbVec, readHistory,
        mutualInformation, ciTest, localDepTest,
-       woeBal, woeHist,
+       woeBal, woeHist, EAPBal,
        fcKappa, gkLambda)
 
 export(isMonotonic,
@@ -53,14 +60,3 @@ S3method(normalize, CPF)
 S3method(normalize, default)
 S3method(normalize, matrix)
 
-## S3method(print, NeticaBN)
-## S3method(toString, NeticaBN)
-## S3method(Ops, NeticaBN)
-## S3method(print, NeticaNode)
-## S3method(toString, NeticaNode)
-## S3method(Ops, NeticaNode)
-## S3method("[", NeticaNode)
-## S3method("[[", NeticaNode)
-## S3method("[<-", NeticaNode)
-
-

R/.gitignore

@@ -0,0 +1,2 @@
+#.*#
+#StackedBars.R#

R/OCP.R

@@ -80,3 +80,27 @@ function (x,n,lclabs,pi, pilab=names(pi),
 ## grouplabs <- c(rep("-",3),"+")
 ## x <- c("(0,0)"=7,"(0,1)"=4,"(1,0)"=2,"(1,1)"=31)
 ## OCP (x,nn,grouplabs,pi,c("-","+"),ylim=c(0,1), reflty=2:3)
+
+
+## eCPTplot <- function(cpf,counts) {
+
+## }
+
+## pct <- tribble(
+##     ~Level, ~count, ~prob,
+##     "High", 1, 1/3,
+##     "Med", 2, 1/3,
+##     "Low", 3, 1/3
+## )
+
+## pct <- tibble(Level=ordered(c("High","Medium","Low"),
+##                             levels=c("High","Medium","Low")),
+##               count=1:3, prob=1/3)
+
+
+
+## full_join(pct,dirchci(pct$prob,pct$Level)) %>%
+##   mutate(xpos=(1:nrow(pct))/nrow(pct)+.5) %>%
+##   ggplot(aes(x=1,y=prob,fill=Level)) +
+##   geom_col() +
+##   geom_pointrange(aes(x=xpos,y=mid,ymin=lower,ymax=upper,shape=Level))

R/StackedBars.R

@@ -320,19 +320,19 @@ barchart.CPF <- function(x, data=NULL, ..., baseCol="firebrick",
     ps <- list(par.settings,
                superpose.polygon=list(col=rev(colorspread(baseCol,nstates))))
   if (nrow(x)==1L) { ## No Parent Case
-    barchart(as.matrix(x),data,auto.key=auto.key, par.settings=ps,...)
+    lattice::barchart(as.matrix(x),data,auto.key=auto.key, par.settings=ps,...)
   } else if (length(getTableParents(x))==1L) { ## One parent
     xx <- numericPart(x)
     rownames(xx) <- factorPart(x)
-    barchart(xx,data,auto.key=auto.key, par.settings=ps,...)
+    lattice::barchart(xx,data,auto.key=auto.key, par.settings=ps,...)
   } else { ## Two or more parents
       xx <- as.CPA(x)
       dd <- dim(xx)
       nstates <- dd[length(dd)]
       for (ddd in 1L:(length(dd)-1L)) {
         dimnames(xx)[[ddd]] <- paste(names(dd)[ddd],"=",dimnames(xx)[[ddd]])
       }
-      barchart(xx,data,auto.key=auto.key, par.settings=ps,...)
+      lattice::barchart(xx,data,auto.key=auto.key, par.settings=ps,...)
     }
 }
 

R/betaci.R

@@ -12,6 +12,15 @@ function (sumData, totals = NULL,
          qbeta(prob,sumData+a,totals-sumData+b))
 }
 
+dirchci <- function (counts, lnames=names(counts),
+                     a = rep(1/length(counts),length(counts)),
+                     limits=c(lower=0.025,mid=.5,upper=0.975)) {
+  tot <- sum(counts+a)
+  dat <- cumsum(counts+a)[-length(counts)]
+  data.frame(Level = lnames[-length(counts)],
+             lapply(limits, qbeta,dat, tot-dat))
+}
+
 
 "proflevelci" <- function(data,profindex,
                           limits=list(lower=.025,upper=.975),

R/woe.R

@@ -80,4 +80,40 @@ woeBal <- function (hist, pos, neg, obs=NULL, title="Evidence Balance Sheet",
   par(oldpar)
   invisible(mids)
 }
-
+
+
+EAPBal <- function (hist, contexts=names(hist), obs=NULL,
+                    varname=deparse(substitute(hist)),elim=c(-1,1),
+                    etic=4,
+                    title=paste("EAP Balance Sheet:",varname),
+                    col="slategray",
+                    posCol="cyan",negCol="red",
+                    stripCol=c("white","lightgray"),
+                    lcex=.65) {
+  oldpar <- par(mfrow=c(1,3),oma=c(0,2,2,2),mar=c(5,0.1,4,0.1)+.01)
+  timesteps <- length(hist)
+  mids <- barplot(c(rep(1,timesteps-1),0),xlab="",ylab="",
+                  xaxt="n",yaxt="n",col=stripCol,horiz=TRUE,
+                  border=NA)
+  text(0,rev(mids),contexts,adj=c(0,0.5),cex=lcex)
+  if (!is.null(obs))
+    text(1,rev(mids),obs,adj=c(1,0.5),cex=lcex)
+
+  xlim <- elim - min(elim)
+  xlen <- diff(elim)
+  barplot(rev(hist)-min(elim),horiz=TRUE,names.arg=NULL,col=col,
+          main=paste("EAP[",varname,"]"),yaxt="n",xaxt="n",xlim=xlim)
+  axis(1,at=seq(xlim[1],xlim[2],xlen/etic),labels=seq(elim[1],elim[2],xlen/etic))
+  abline(v=mean(xlim))
+  dhist <- diff(hist)
+  barplot(rev(c(NA,dhist)),horiz=TRUE,names.arg=NULL,
+          col=c(ifelse(rev(dhist)<0,negCol,posCol),"black"),
+          xlim=elim,
+          main=paste("\u0394EAP[",varname,"]"),
+          yaxt="n")
+  abline(v=0)
+  mtext(title,outer=TRUE)
+  par(oldpar)
+  invisible(mids)
+}
+

demo/Timeseries.R

@@ -0,0 +1,69 @@
+library(googlesheets4)
+library(tidyverse)
+library(cowplot)
+
+formA.hist <- read_sheet("https://docs.google.com/spreadsheets/d/1svdCQI9Jb3MpIObGWExg942MUsBB4uRquhD1FNTkChM/edit#gid=688471781",1)
+View(formA.hist)
+
+## Need to fix baseline timestamp
+
+min(formA.hist$timestamp,na.rm=TRUE) -> first.post
+base.timestamp <- as.POSIXlt(first.post)
+## Put at the top of the hours.
+base.timestamp$min <-0
+base.timestamp$sec <-0
+base.timestamp <- as.POSIXct(base.timestamp)
+
+formA.hist[formA.hist$context=="*Baseline*","timestamp"] <- as.POSIXct(base.timestamp)
+
+filter(formA.hist, uid=="011c1") %>% ggplot(aes(x=timestamp,y=Physics_EAP)) + geom_line() + geom_text(aes(label=context))
+
+fiveuid <- sample(unique(formA.hist$uid),5)
+filter(formA.hist, uid %in% fiveuid) %>% ggplot(aes(x=timestamp,y=Physics_EAP)) + geom_line() +
+  facet_grid(rows=vars(uid))
+
+
+## ndiff differences the series, leaving the first (baseline) value as NA.
+## Thus is is a candidate aux function for mutate.
+ndiff <- function (x) {
+  res <- c(NA,diff(x))
+  names(res) <- names(x)
+  res
+}
+Phys1 <- filter(formA.hist,uid=="011c1") %>% pull(Physics_EAP)
+names(Phys1) <- filter(formA.hist,uid=="011c1") %>% pull(context)
+
+## Plots versus timestamps.  Hard to see what is going on.
+filter(formA.hist, uid=="011c1") %>% ggplot(aes(x=timestamp,y=ndiff(Physics_EAP))) + geom_line()
+filter(formA.hist, uid %in% fiveuid) %>% ggplot(aes(x=timestamp,y=Physics_EAP)) + geom_line() +
+  facet_grid(rows=vars(uid))
+filter(formA.hist, uid %in% fiveuid) %>% ggplot(aes(x=timestamp,y=ndiff(Physics_EAP))) + geom_line() +
+  facet_grid(rows=vars(uid))
+
+## Working with discrete time.
+## 1) Need to use geom_col() not geom_bar()
+## 2) fct_reorder(context,timestamp) makes sure levels are in time order, not alphabetical!!
+## 3) scale_fill_gradient2(low="red",mid="yellow",high="green") gives traffic light coloring.
+## 4) theme(axis.text.y=element_blank()) suppresses the labels in the second plot.
+## 5) cowplot::plot_grid() plots side by side.
+
+c011c1.eap <- filter(formA.hist, uid=="011c1") %>% ggplot(aes(x=fct_reorder(context,timestamp),y=Physics_EAP)) +
+    geom_col(aes(fill=..y..))+scale_fill_gradient2(low="red",mid="yellow",high="green",midpoint=0)+
+    coord_flip(ylim=c(-1,1))+theme_light()+labs(x="",y="EAP[Physics]")
+c011c1.diff <- filter(formA.hist, uid=="011c1") %>% ggplot(aes(x=fct_reorder(context,timestamp),y=ndiff(Physics_EAP))) +
+  geom_col(aes(fill=..y..))+scale_fill_gradient2(low="red",mid="yellow",high="green",midpoint=0)+
+  coord_flip(ylim=c(-1,1))+theme_light()+labs(x="",y="\u0394EAP[Physics]") + theme(axis.text.y=element_blank())
+
+plot_grid(c011c1.eap,c011c1.diff)
+
+## Remaining Issues:
+# 1) Probably want 3 plots:  level names and trophies, EAP, Delta EAP
+#### Need to merge trophy data in with levels.
+# 2) There could be more than one level with the same context.  Need to fix.
+####  Maybe plotting by order number will fix this.
+# 3) Need to figure out how to add "outer" labels to multiplot Grid.
+
+
+EAPBal(filter(formA.hist,uid=="011c1") %>% pull("Physics_EAP"),
+       filter(formA.hist,uid=="011c1") %>% pull("context"),
+       varname="Physics")

man/.gitignore

@@ -0,0 +1 @@
+#woeBal.Rd#

man/CPA.Rd

@@ -115,8 +115,9 @@ as.CPA(x)
   \code{\link{CPF}}, \code{\link{normalize}()}
 }
 \examples{
-arf <- data.frame(A=rep(c("a1","a2"),each=3),
-                  B=rep(c("b1","b2","b3"),2),
+# Note:  in R 4.0, the factor() call is required.
+arf <- data.frame(A=factor(rep(c("a1","a2"),each=3)),
+                  B=factor(rep(c("b1","b2","b3"),2)),
                   C.c1=1:6, C.c2=7:12, C.c3=13:18, C.c4=19:24)
 arfa <- as.CPA(arf)
 stopifnot(

man/CPF.Rd

@@ -94,14 +94,22 @@ as.CPF(x)
 
   Note, this is an S3 class, as it is basically a data.frame with
   special structure.
+
+  \emph{Change in R 4.0}.  Note that under R 4.0, character vectors are
+  no longer automaticall coerced into factors when added to data
+  frames.  This is probably a good thing, as the code can assume that a
+  column that is a factor is an index for a variable, and one that is a
+  character is a comment or some other data.
 }
+
 \seealso{
   \code{\link[RNetica]{NodeProbs}()}, \code{\link[RNetica]{Extract.NeticaNode}},
   \code{\link{CPA}}, \code{\link{normalize}()}
 }
 \examples{
-arf <- data.frame(A=rep(c("a1","a2"),each=3),
-                  B=rep(c("b1","b2","b3"),2),
+# Note:  in R 4.0, the factor() call is required.
+arf <- data.frame(A=factor(rep(c("a1","a2"),each=3)),
+                  B=factor(rep(c("b1","b2","b3"),2)),
                   C.c1=1:6, C.c2=7:12, C.c3=13:18, C.c4=19:24)
 arf <- as.CPF(arf)
 stopifnot(is.CPF(arf))

man/Compensatory.Rd

@@ -71,7 +71,7 @@ Morgan Kaufmann, 137--143.
   as they have the same signature as these functions.
 }
 \examples{
-  thetas <- expand.grid(list(S1=(3:1 -2), S2 = (3:1 -2)))
+  thetas <- expand.grid(list(S1=seq(1,-1), S2 = seq(1, -1)))
   Compensatory(thetas, c(S1=1.25,S2=.75), 0.33)
   Conjunctive(thetas, c(S1=1.25,S2=.75), 0.33)
   Disjunctive(thetas, c(S1=1.25,S2=.75), 0.33)