我一直在自学如何制作闪亮的应用程序，以包含机智的研究文章，以使从业者更容易使用方法。我正在使用闪亮来制作一个对特定变量集进行判别函数分析的网络应用程序。当从分析中选择 3 个或更多组时，该应用程序工作得很好，但是当我使用 switch 函数将代码更改为 2 组时，我遇到了不正确的维数错误。代码运行良好，然后我更新了 R 和 rStudio，现在每当我尝试 2 组比较时，我都会收到“不正确的维度数”。我一直在尝试调试几个小时，但无济于事。
在闪亮的界面中，用户可以在两组分析和多组分析之间进行选择，选择组，然后将数据输入数据输入表。我设置了表格，以便根据输入的任何变量，参考数据都是子集。
下面是 server.R 代码——请原谅糟糕的编码状态——这是我的第一次尝试，我正在学习。
和服务器.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])
})
})
我尝试更改将开关功能放在 lda_mod 中的位置，但同样的问题不断出现。任何建议将不胜感激。