Incorrect number of dimensions when switching between 2 group and more than 2 group LDA in Shiny - switch-statement

Question

I have been teaching myself how to make shiny apps to include wit research articles to make methods more available to practitioners. I am using shiny to make a web app that does discriminant function analysis on a certain set of variables. The application works just fine when 3 or more groups are selected from the analysis, but when I used the switch function to alter the code to 2 groups, I am running into an incorrect number of dimensions error. The code was working fine and then I updated R and rStudio and now whenever I try the 2 group comparisons, I received "incorrect number of dimensions". I have been trying to debug for a few hours to no avail.
In the shiny interface the user can select between a two group analysis and a more than 2 group analysis, select the groups and then enter the data into a data entry table. I have the table set up so that the reference data is subset according to whichever variables are entered.
Below is the server.R code - please forgive the awful state of the coding - this is my first attempt and I am learning as I go.
And the server.R
server.R
mand<-read.csv("data/berg_full.csv", sep=',', header = T)
library(shiny)
library(knitr)
library(httr)
library(fields)
library(psych)
library(dplyr)
library(PerformanceAnalytics)
library(caret)
library(e1071)
library(DT)
library(MASS)
library(stats)
library(klaR)
library(Morpho)
shinyServer(function(input, output) {
# get the reference data from the selectize input
refdata <- reactive({
input$evaluate
isolate({
if(length(input$refsamp) == 0) return(NULL)
switch(input$refsamp,
"mandible" = mand,
NULL)
})
})
getdata<-reactive({
input$evaluate
filtereddata<-refdata()
filtereddata<- filtereddata %>% filter(Group %in% input$group) %>% droplevels()
return(filtereddata)
})
elements <- reactive({
input$evaluate
isolate({
elements <- c()
if(!is.na(input$GNI)) elements <- c(elements, "GNI" = input$GNI)
if(!is.na(input$HML)) elements <- c(elements, "HML" = input$HML)
if(!is.na(input$TML)) elements <- c(elements, "TML" = input$TML)
if(!is.na(input$GOG)) elements <- c(elements, "GOG" = input$GOG)
if(!is.na(input$CDL)) elements <- c(elements, "CDL" = input$CDL)
if(!is.na(input$WRB)) elements <- c(elements, "WRB" = input$WRB)
if(!is.na(input$XRH)) elements <- c(elements, "XRH" = input$XRH)
if(!is.na(input$MLT)) elements <- c(elements, "MLT" = input$MLT)
if(!is.na(input$MAN)) elements <- c(elements, "MAN" = input$MAN)
if(!is.na(input$XDA)) elements <- c(elements, "XDA" = input$XDA)
if(!is.na(input$TLM23)) elements <- c(elements, "TLM23" = input$TLM23)
if(!is.na(input$CS)) elements <- c(elements, "CS" = input$CS)
if(!is.na(input$L_Bord)) elements <- c(elements, "L_Bord" = input$L_Bord)
if(!is.na(input$AscRam)) elements <- c(elements, "AscRam" = input$AscRam)
if(!is.na(input$GF)) elements <- c(elements, "GF" = input$GF)
if(!is.na(input$MT)) elements <- c(elements, "MT" = input$MT)
if(!is.na(input$PREI)) elements <- c(elements, "PREI" = input$PREI)
if(length(elements) == 0) return(NULL)
return(data.frame(as.list(elements)))
})
})
##create elements input table
el_names <- c("<h4>Metric</h4>", "<h5>New Data</h5>")
GNI <- c("GNI",
"<input id='GNI' class='shiny-bound-input' type='number' value='NA' min='0' max='50'>"
)
HML <- c("HML",
"<input id='HML' class='shiny-bound-input' type='number' value='NA' min='0' max='50'>"
)
TML <- c("TML",
"<input id='TML' class='shiny-bound-input' type='number' value='NA' min='0' max='25'>"
)
GOG <- c("GOG",
"<input id='GOG' class='shiny-bound-input' type='number' value='NA' min='0' max='150'>"
)
CDL <- c("CDL",
"<input id='CDL' class='shiny-bound-input' type='number' value='NA' min='0' max='160'>"
)
WRB <- c("WRB",
"<input id='WRB' class='shiny-bound-input' type='number' value='NA' min='0' max='100'>"
)
XRH <- c("XRH",
"<input id='XRH' class='shiny-bound-input' type='number' value='NA' min='0' max='100'>"
)
MLT <- c("MLT",
"<input id='MLT' class='shiny-bound-input' type='number' value='NA' min='0' max='150'>"
)
MAN <- c("MAN",
"<input id='MAN' class='shiny-bound-input' type='number' value='NA' min='0' max='180'>"
)
XDA <- c("XDA",
"<input id='XDA' class='shiny-bound-input' type='number' value='NA' min='0' max='100'>"
)
TLM23 <- c("TLM23",
"<input id='TLM23' class='shiny-bound-input' type='number' value='NA' min='0' max='100'>"
)
output$el_table <- renderTable({
data.frame(el_names, GNI, HML, TML, GOG, CDL, WRB, XRH, MLT, MAN, XDA, TLM23)
}, sanitize.text.function = function(x) x, sanitize.rownames.function = function(x) x, sanitize.colnames.function = function(x) x, include.rownames = FALSE, include.colnames = FALSE)
el_names1 <- c("<h4>Morphoscopic</h4>", "<h5>New Data</h5>")
CS <- c("Chin Shape",
"<input id='CS' class='shiny-bound-input' type='number' value='NA' min='1' max='4'>"
)
L_Bord <- c("LBM",
"<input id='L_Bord' class='shiny-bound-input' type='number' value='NA' min='1' max='4'>"
)
AscRam <- c("Ascending Ramus",
"<input id='AscRam' class='shiny-bound-input' type='number' value='NA' min='1' max='4'>"
)
GF <- c("Gonial Flare",
"<input id='GF' class='shiny-bound-input' type='number' value='NA' min='1' max='5'>"
)
MT <- c("Mand. Torus",
"<input id='MT' class='shiny-bound-input' type='number' value='NA' min='1' max='2'>"
)
PREI <- c("PREI",
"<input id='PREI' class='shiny-bound-input' type='number' value='NA' min='1' max='4'>"
)
output$el_table1 <- renderTable({
data.frame(el_names1, CS, L_Bord, AscRam, GF, MT, PREI)
}, sanitize.text.function = function(x) x, sanitize.rownames.function = function(x) x, sanitize.colnames.function = function(x) x, include.rownames = FALSE, include.colnames = FALSE)
## create reference data from new data
refsamp <- reactive({
if (is.null(getdata()) | is.null(elements())) return()
ref <- dplyr::select_(getdata(), .dots = c("Group", names(elements()))) %>% droplevels()
return(ref)
})
## create lda model, plot, and typicality probabilities
lda_mod <- eventReactive(input$evaluate, {
lda_data<-na.omit(refsamp()) %>% droplevels()
ngroups<-nlevels(lda_data$Group)
lda_formula<-as.formula(Group ~ .)
if(length(input$numgroups) == 0) return(NULL)
switch(input$numgroups,
"multigroup" = {
model_group<-MASS::lda(lda_formula, data = lda_data, prior= rep(1, ngroups)/ngroups)
model_group1<-MASS::lda(lda_formula, data = lda_data, prior= rep(1, ngroups)/ngroups, CV=TRUE)
tracetab<-prop.table(model_group$svd^2)
df1v<-round((tracetab[1]), digits=3)
df2v<-round((tracetab[2]), digits=3)
estgroup<-data.frame(predict(model_group, newdata = elements(), type="class", CV=TRUE))
groupprob<-predict(model_group, newdata=elements(), type="posterior", CV=TRUE)
pp<-as.data.frame(round(groupprob$posterior, digits=3))
p<-predict(model_group, lda_data, CV=T)
ct<-table(lda_data$Group, model_group1$class)
cm<-caret::confusionMatrix(ct)
con<-cm
n<-as.matrix(model_group$counts)
colnames(n)<-c("n")
classmat<-cbind(n, ct)
tcc<-paste(sum(diag(ct)), "out of", sum(ct), "correct", "=", (100*(round(sum(diag(prop.table(ct))), digits=3))), "%", "Total Correct Classification Cross-validated")
percenttab<-tcc
ppv<-as.data.frame(con$byClass[,3])
colnames(ppv)<-c("PPV")
x<-p$x[,1]
y<-p$x[,2]
Group<-lda_data$Group
df<-data.frame(Group,x,y)
centroids<-aggregate(cbind(x,y)~Group,df,mean)
cen<-as.matrix(centroids)
qx<-as.numeric(estgroup$x.LD1)
qy<-as.numeric(estgroup$x.LD2)
inddist<-data.frame(qx, qy)
indie<-as.matrix(inddist)
eucdist<-fields::rdist(cen[,2:3], indie)
grouplev<-data.frame(model_group$lev)
eucdist1<-cbind(grouplev, round(eucdist, digits=3))
colnames(eucdist1)<-c("Group", "Dist.")
ldaplot<-ggplot2::ggplot(data=df, aes(x, y, color=Group)) + geom_point(alpha=0.5) + labs(x="DF1", y="DF2") + geom_point(data=centroids, size=5) + geom_point(aes(x=estgroup$x.LD1, y=estgroup$x.LD2), size=6, col="black", pch=8) + stat_ellipse(type="norm", level=0.90)
},
"twogroup" = {
model_group<-MASS::lda(lda_formula, data = lda_data, prior= rep(1, ngroups)/ngroups, na.action=na.omit)
model_group1<-MASS::lda(lda_formula, data = lda_data, prior= rep(1, ngroups)/ngroups, CV=TRUE)
tracetab<-prop.table(model_group$svd^2)
df1v<-round((tracetab[1]), digits=3)
estgroup<-data.frame(predict(model_group, newdata = elements(), type="class", CV=TRUE))
groupprob<-predict(model_group, newdata=elements(), type="posterior", CV=TRUE)
pp<-as.data.frame(round(groupprob$posterior, digits=3))
p<-predict(model_group, lda_data, CV=T)
ct<-table(lda_data$Group, model_group1$class)
cm<-caret::confusionMatrix(ct)
con<-cm
n<-as.matrix(model_group$counts)
colnames(n)<-c("n")
classmat<-cbind(n, ct)
tcc<-paste(sum(diag(ct)), "out of", sum(ct), "correct", "=", (100*(round(sum(diag(prop.table(ct))), digits=3))), "%", "Total Correct Classification Cross-validated")
percenttab<-tcc
ppv<-as.data.frame(con$byClass[,3])
colnames(ppv)<-c("PPV")
x<-p$x[,1]
Group<-lda_data$Group
df<-data.frame(Group,x)
centroids<-aggregate(cbind(x)~Group,df,mean)
cen<-as.matrix(centroids)
qx<-as.numeric(estgroup$LD1)
inddist<-data.frame(qx)
indie<-as.matrix(inddist)
eucdist<-fields::rdist(cen[,2], indie)
grouplev<-data.frame(model_group$lev)
eucdist1<-cbind(grouplev, round(eucdist, digits=3))
colnames(eucdist1)<-c("Group", "Dist.")
ldaplot<-ggplot2::ggplot(data=df, aes(x=x, fill=Group)) + geom_histogram() + labs(x="Discriminant Function Score", y="Count") + geom_vline(aes(xintercept=qx))
}
)
return(list(model_group, estgroup,groupprob, p, ct, cm, ldaplot, qx, qy, pp, df1v, df2v, classmat, percenttab, tcc, ppv, eucdist1, model_group1))
})
classmatrix <- eventReactive(input$evaluate, {
fit<-lda_mod()[[1]]
ctab<-lda_mod()[[5]]
n<-as.matrix(fit$counts)
colnames(n)<-c("n")
nclassmat<-cbind(n, ctab)
classperc<-(100*round(prop.table(ctab,1), digits=3))
right<-sum(diag(ctab))
of<-sum(ctab)
totalcorrect<-100*(round(sum(diag(prop.table(ctab))), digits=3))
return(list(nclassmat, classperc, right, of, totalcorrect))
})
tps <- eventReactive(input$evaluate, {
tdat<-refsamp()
sub<-na.omit(tdat)
ngroups<-nlevels(tdat$Group)
g<-sub$Group
g<-as.vector(g)
fit<-MASS::lda(Group ~., data=sub, prior= rep(1, ngroups)/ngroups)
p<-predict(fit, sub)
ref<-as.matrix(p$x[,1], p$x[,2])
ind<-elements()
est<-predict(fit, ind)
pred<-as.matrix(est$x[,1], est$x[,2])
typClass<-typprobClass(pred, ref, groups = g, method="chisquare", cv=TRUE, sep=T, robust="mcd")
tp<-as.data.frame(round(typClass$probs, digits=3))
return(list(tp))
})
elemnames<-eventReactive(input$evaluate, {
enames<-elements()
return(list(enames))
})
Tech <-reactive({
input$tech
})
Case <-reactive({
input$case
})
TECH<-eventReactive(input$evaluate,{
techie<-Tech()
return(list(techie))
})
CASE<-eventReactive(input$evaluate,{
case1<-Case()
return(list(case1))
})
## summary statistics by group
datasummary<-eventReactive(input$evaluate, {
gd<-refsamp()
gd<-na.omit(gd)
groupsummary<-psych::describeBy(gd, group='Group')
return(list(groupsummary))
})
## output group classification
output$lda_pred <- renderText({
if(is.null(lda_mod())) return()
a<-lda_mod()[[2]]
paste("Predicted Group =", a[,1])
})
##output for model summary
output$modsum <- renderPrint({
if(is.null(lda_mod())) return()
lda_mod()[[1]]
})
## output posterior probabilities
output$lda_prob <- renderPrint({
if(is.null(lda_mod())) return()
posteriors<- lda_mod()[[10]]
print(posteriors[order(-posteriors[1,])], row.names=FALSE)
})
## output typicality probabilities
output$typs <- renderPrint({
if(is.null(tps())) return()
typsy<- tps()[[1]]
print(typsy[order(-typsy[1,])], row.names=FALSE)
})
##output distance from centroids
output$cendist<-renderPrint({
if(is.null(lda_mod())) return()
distcen<-lda_mod()[[17]]
print(distcen[order(distcen[,2]),], row.names=FALSE)
})
## output confusion matrix
output$confusionm<-renderPrint({
if(is.null(classmatrix())) return()
classmatrix()[[1]]
})
## output percent confusion matrix
output$confusionm1<-renderPrint({
if(is.null(classmatrix())) return()
classmatrix()[[2]]
})
## output total correct classification
output$confusionm2<-renderText({
if(is.null(classmatrix())) return()
paste(classmatrix()[[3]], "out of", classmatrix()[[4]], "=", classmatrix()[[5]],"%", "Total Correct Classification Cross-validated")
})
## output positive predictive value
output$confusionm3<-renderPrint({
if(is.null(lda_mod())) return()
pospred<-lda_mod()[[16]]
round(pospred, digits=3)
})
## output summary statistics
output$summarystat<-renderPrint({
if(is.null(datasummary())) return()
datasummary()[[1]]
})
#scatterplot output
output$ldaplot<- renderPlot({
if(is.null(lda_mod())) return()
lda_mod()[[7]]
})
# New data LD scores
output$number1 <- renderText({
if(is.null(lda_mod())) return()
ld1<-lda_mod()[[8]]
ldv1<-lda_mod()[[11]]
paste("Classified Individual's DF1 Score = ", round(ld1, digits=3), "Variation Accounted For in DF1:", round((ldv1*100), digits=2),"%")
})
# New data LD scores
output$number2 <- renderText({
if(is.null(lda_mod())) return()
ld2<-lda_mod()[[9]]
ldv2<-lda_mod()[[12]]
paste("Classified Individual's DF2 Score = ", round(ld2, digits=3), "Variation Accounted For in DF2:", round((ldv2*100), digits=2),"%")
})
## output model specs
output$modelspec<-renderPrint({
if(is.null(lda_mod())) return()
lda_mod()[[1]]
})
##case number
output$casenum<- renderPrint({
cake<-CASE()[[1]]
print(as.name(cake), row.names=FALSE)
})
##case analyst
output$analyst<- renderPrint({
tach<-TECH()[[1]]
print(as.name(tach), row.names=FALSE)
})
##output Title and Date
output$title<-renderPrint({
today<-Sys.Date()
cat(sprintf('Sex and Ancestry Estimation Report %s\n', today))
})
##output variables and measures for case
output$elnamez<-renderPrint({
e<-elemnames()[[1]]
print(e, row.names=FALSE)
})
## output confusion matrix print
output$confusionmp<-renderPrint({
if(is.null(classmatrix())) return()
classmatrix()[[1]]
})
## output total correct classificationprint
output$confusionm2p<-renderText({
if(is.null(classmatrix())) return()
paste(classmatrix()[[3]], "out of", classmatrix()[[4]], "=", classmatrix()[[5]], "%", "Total Correct Classification Cross-validated")
})
## output percent confusion matrix print
output$confusionm1p<-renderPrint({
if(is.null(classmatrix())) return()
classmatrix()[[2]]
})
## output posterior probabilities print
output$lda_probp <- renderPrint({
if(is.null(lda_mod())) return()
posteriors1<-lda_mod()[[10]]
print(posteriors1[order(-posteriors1[1,])], row.names=FALSE)
})
## output typicality probabilities print
output$typsp <- renderPrint({
if(is.null(tps())) return()
typsy1<- tps()[[1]]
print(typsy1[order(-typsy1[1,])], row.names=FALSE)
})
#scatterplot output print
output$ldaplotp<- renderPlot({
if(is.null(lda_mod())) return()
lda_mod()[[7]]
})
## output group classification
output$ldapredp <- renderText({
if(is.null(lda_mod())) return()
a<-lda_mod()[[2]]
paste("Predicted Group =", a[,1])
})
})
I have tried changing where I put the switch function in the lda_mod but the same issue keeps coming up. Any suggestions would be much appreciated.

Answer 1

Figured it out. When calling on the output value for positive predictive value in confusionMatrix, the subset [,3] worked in the multigroup case and for the 2 group case, it would only accept [3].