I'm making an r shiny application, based on a partially linear additive model. For this, I need to estimate some parameters, and I'm doing this from a function that acts in a practically recursive way until convergence occurs, and I'm having a problem in this function, where it needs to return more than one object (so, I made its output a list), but when I try to use it in the main program I can't extract the values, And so, I can't plot the chart I want.
Also, I tried using the reactlog package to see if I could get an idea if there were any errors in the reactive uses, but for some reason, it's not considering the inputs that are real values. Still, I used the browser() function and I know that all the code before calling the additive model.function is working normally.
Probably the function I created (the one that returns a list) is not relevant in fixing the problem, but I leave it below in case it can be important:
modelo.aditivo <- function(X,Y,Z,alfa,ndx,tipo.N = 1,it= 500, criterio = 1e-3){
n <- nrow(X) # número de observações
n_b <- ncol(X) # número de parâmetros beta
n_g <- ncol(Z) # número de parâmetros de vetor gamma
N <- list()
K <- list()
if(tipo.N == 1){
dados <- data.frame(Z)
ZZ<-smoothCon(s(x1,bs="cr",k=ndx[1]),data=dados, knots=NULL, absorb.cons=T)
N[[1]]<-ZZ[[1]]$X
K[[1]]<-(ZZ[[1]]$S)[[1]]
ZZ2<-smoothCon(s(x2,bs="cr",k=ndx[2]),data=dados,knots=NULL, absorb.cons=T)
N[[2]]<-ZZ2[[1]]$X
K[[2]]<-(ZZ2[[1]]$S)[[1]]
} else {
N1 <- ({bsplinec(Z[,1],ndx[1],4)})
Dk1 <- ({diff(diag(ncol(N1)),differences = 2)})
K1 <- ({t(Dk1)%*%Dk1})
N2 <- ({bsplinec(Z[,2],ndx[2],4)})
Dk <- ({diff(diag(ncol(N2)),differences = 2)})
K2 <- ({t(Dk)%*%Dk})
N <- list(N1,N2)
K <- list(K1,K2)
}
gamma0 <- list() # armazena espaço para os gammas iniciais
beta0 <- solve(t(X)%*%X)%*%t(X)%*%Y # cálculo do chute inicial para beta
for(i in 1:n_g){
gamma0[[i]] <- solve(t(N[[i]])%*%N[[i]] + alfa[i]*K[[i]])%*%t(N[[i]])%*%(Y-X%*%beta0) # cálculo do chute inicial para os gammas
}
somatorio <- apply((sapply(1:n_g,FUN = function(i) N[[i]]%*%gamma0[[i]])),1,sum)
var0 <- as.numeric((t(Y-X%*%beta0-somatorio)%*%(Y-X%*%beta0-somatorio))/n)
theta0 <- matrix(c(beta0,unlist(gamma0),var0))
tams <- cumsum(c(length(beta0),lengths(gamma0),1))
val <- criterio*1.1
while((val > criterio)&&(it>0)){
it <- it - 1
somatorio <- apply((sapply(1:n_g,FUN = function(i) N[[i]]%*%gamma0[[i]])),1,sum)
beta0 <- solve(t(X)%*%X)%*%t(X)%*%(Y-somatorio)
var0 <- as.numeric((t(Y-X%*%beta0-somatorio)%*%(Y-X%*%beta0-somatorio))/n)
for(i in 1:n_g){
soma <- apply((sapply(1:n_g,FUN = function(i) N[[i]]%*%gamma0[[i]])),1,sum) - N[[i]]%*%gamma0[[i]]
gamma0[[i]] <- solve(t(N[[i]])%*%N[[i]] + alfa[i]*var0*K[[i]])%*%t(N[[i]])%*%(Y-X%*%beta0-soma)
}
theta <- matrix(c(beta0,unlist(gamma0),var0))
val <- abs(lp(theta0,Y,X,N,K,alfa,tams)-lp(theta,Y,X,N,K,alfa,tams))
theta0 <- theta
}
list(par = theta,
N = N,
K = K,
tams = tams)
}
And the R shiny app is:
ui <- fluidPage(
titlePanel("Visualização dos alphas"),
sidebarLayout(
sidebarPanel(
sliderInput("alpha1", "Escolha um valor de alpha para a curva 1",
min = 0.0, max = 500.0, value = 1.0,step = 0.01,
animate =
animationOptions(interval = 50, loop = F)),
sliderInput("alpha2", "Escolha um valor de alpha para a curva 2",
min = 0.0, max = 500.0, value = 1.0,step = 0.01,
animate =
animationOptions(interval = 50, loop = F)),
numericInput("n.no1", "Escolha o número de nós para a curva 1",
min = 1, max = 1000, value = 12,step = 1),
numericInput("n.no2", "Escolha o número de nós para a curva 2",
min = 1, max = 1000, value = 12,step = 1),
numericInput("tamanho", "Defina a quantidade de valores gerados",
min = 20, max = 10000, value = 1000),
numericInput("variancia", "Defina a variancia",
min = 0.00001, max = 10.0, value = 0.1)
),
mainPanel(
plotOutput("grafico1"),
plotOutput("grafico2")
)
),
)
server <- function(input, output) {
n <- reactive({
input$tamanho
})
v <- reactive({
input$variancia
})
x1 <- reactive({runif(n = n(), min = 0.6, max = 1.6)})
x2 <- reactive({runif(n = n(), min = 2, max = 4*pi)})
Z <- reactive({cbind(x1(),x2())})
f.x1 <- reactive({cos(-4*x1()*pi)*exp(-x1()^2/2)})
f.x2 <- reactive({cos(x2())})
x3 <- reactive({rexp(n()) - 2})
x4 <- reactive({rnorm(n()) - 5})
X <- reactive({cbind(x3(),x4())})
betas <- matrix(c(1,-2),ncol = 1)
mi <- reactive({X()%*%betas + f.x1() + f.x2()})
erros <- reactive({rnorm(n(),0,sqrt(v()))})
Y <- reactive({mi() + erros()})
ndx <- reactive({c(input$n.no1,input$n.no2)})
alfa <- reactive({c(input$alpha1,input$alpha2)})
o1 <- reactive({order(x1())})
o2 <- reactive({order(x2())})
resultado <- reactive({modelo.aditivo(X(), Y(), Z(), alfa(), ndx())})
theta <- reactive({resultado()$par})
N <- reactive({resultado()$N})
K <- reactive({resultado()$K})
tams <- reactive({resultado()$tams})
gamma1 <- reactive({theta()[(tams()[1]+1):tams()[2]]})
gamma2 <- reactive({theta()[(tams()[2]+1):tams()[3]]})
output$grafico1 <- renderPlot({
plot(x1()[o1()],f.x1()[o1()],type = "l",col = "blue", lwd = 2)
lines(x1()[o1()],resultado()$N[[1]][o1(),]%*%gamma1(), col = "red",lwd = 3)
})
output$grafico2 <- renderPlot({
plot(x2()[o2()],f.x2()[o2()],type = "l",col = "blue", lwd = 2)
lines(x2()[o2()],resultado()$N[[2]][o2(),]%*%gamma2(), col = "red",lwd = 3)
})
}
shinyApp(ui = ui, server = server)
Finally, the error that has appeared is 'names' attribute [1] must be the same length as the vector [0], but I've tried several ways and I haven't been successful in solving it.
I'm a beginner in the use of r shiny and the forum, I apologize if the doubt or program has been confused and I thank you very much to anyone who has any tips or suggestions
When you create Z in your server function, you do not name the columns. Later, inside modelo.aditivo the data.frame call gives default names X1 and X2. Since you were expecting the columns to be named x1 and x2 with lower case, you get an error about the names.
Either switch to
ZZ<-smoothCon(s(X1,bs="cr",k=ndx[1]),data=dados, knots=NULL, absorb.cons=T)
N[[1]]<-ZZ[[1]]$X
K[[1]]<-(ZZ[[1]]$S)[[1]]
ZZ2<-smoothCon(s(X2,bs="cr",k=ndx[2]),data=dados,knots=NULL, absorb.cons=T)
or preferably name the columns when you create Z
Z <- reactive({cbind(x1 = x1(),x2 = x2())})
After fixing that problem, I now get an error
Warning: Error in lp: could not find function "lp"
I'm guessing this is from the lpSolve package. After adding the appropriate library() call, I get a different error the condition has length > 1.
I don't really know what these functions are all about. But since you say that modelo.aditivo works outside of Shiny, perhaps you should post some non-reactive fixed values for which the function gives a correct output.