Every time I try to run the shiny app on R I get this error. How to fix it?
I found out that the error is regarding samples <- matrix(sample(1:n),ncol=K)
But I don't understand why.
This is the code of my server:
server <- function(input, output) {
output$distPlot <- renderPlot({
r=input$r
n=input$n
K=input$k
sim=input$sim
p=input$p
noi=input$noi
lsEigen0 <- replicate(1, matrix(rep(0, sim*p),
nrow=sim, ncol = p), simplify=FALSE)
lsmethod0 <- replicate(1, matrix(rep(0, sim*p),
nrow=sim, ncol = p), simplify=FALSE)
choose0 <- replicate(1, rep(0, p), simplify=FALSE)
for (i in 1:sim) {
samples <- matrix(sample(1:n), ncol=K)
#df <- rmvnorm(n = n, mean = rep(0, p), sigma = diag(p))
#data0 <- dataset(df,r,noi)
#for (da in 1:1) {
# lsEigen0[[da]][i,] <- svd(data0[[da]])$d
#lsmethod0[[da]][i,] <- method(data0[[da]], samples)
#min_err0 <- which.min(lsmethod0[[da]][i,])
#choose0[[da]][min_err0] <- choose0[[da]][min_err0] +1
#}
}
#par(mfrow=c(1,2))
#plot1 = plot(1:p, colMeans(lsEigen0[[1]]),
xlab="kth Eigenvalue", ylab="Value",
main="Scree plot data set ", type = "b", pch = 19,
lty = 1, col = 1)
#plot2 = plot(1:p, colMeans(lsmethod0[[1]]), xlab="Rank r",
ylab="Value", main= "Error data set ",
type = "b", pch = 19, lty = 1, col = 1)
})
}
# Run the application
shinyApp(ui = ui, server = server)
The code runs but in the shiny app I get the error
I have tried to fix it by myself but I don't get it.
Related
everyone I am trying to execute the code in found in the book "Flexible Imputation of Missing Data 2ed" in 2.5.3 section, that calculates a confidence interval for two imputation methods. The problem is that I cannot reproduce the results as the result is always NaN
Here is the code
require(mice)
# function randomly draws artificial data from the specified linear model
create.data <- function(beta = 1, sigma2 = 1, n = 50, run = 1) {
set.seed(seed = run)
x <- rnorm(n)
y <- beta * x + rnorm(n, sd = sqrt(sigma2))
cbind(x = x, y = y)
}
#Remove some data
make.missing <- function(data, p = 0.5){
rx <- rbinom(nrow(data), 1, p)
data[rx == 0, "x"] <- NA
data
}
# Apply Rubin’s rules to the imputed data
test.impute <- function(data, m = 5, method = "norm", ...) {
imp <- mice(data, method = method, m = m, print = FALSE, ...)
fit <- with(imp, lm(y ~ x))
tab <- summary(pool(fit), "all", conf.int = TRUE)
as.numeric(tab["x", c("estimate", "2.5 %", "97.5 %")])
}
#Bind everything together
simulate <- function(runs = 10) {
res <- array(NA, dim = c(2, runs, 3))
dimnames(res) <- list(c("norm.predict", "norm.nob"),
as.character(1:runs),
c("estimate", "2.5 %","97.5 %"))
for(run in 1:runs) {
data <- create.data(run = run)
data <- make.missing(data)
res[1, run, ] <- test.impute(data, method = "norm.predict",
m = 2)
res[2, run, ] <- test.impute(data, method = "norm.nob")
}
res
}
res <- simulate(1000)
#Estimate the lower and upper bounds of the confidence intervals per method
apply(res, c(1, 3), mean, na.rm = TRUE)
Best Regards
Replace "x" by tab$term == "x" in the last line of test.impute():
as.numeric( tab[ tab$term == "x", c("estimate", "2.5 %", "97.5 %")])
I'm looking for a way to get all plots of the variables without hitting enter each time.
if you're familiar with this function clprofiles of Kprototype, you know this message Hit <Return> to see next plot:, i want to see all plots of the variables at once.
Now i've tried doing a 'for loop' after the instruction clprofiles(kpres, df) :
clprofiles(kpres, df)
for (i in 1:length(t)) {
print("
")
}
But it's useless.
Thanks for your help.
In that case, you will have to override the default behaviour of clprofiles. Add this new function my.clprofiles to your script:
my.clprofiles <- function(object, x, vars = NULL, col = NULL){
library(RColorBrewer)
if(length(object$cluster) != nrow(x)) stop("Size of x does not match cluster result!")
if(is.null(vars)) vars <- 1:ncol(x)
if(!is.numeric(vars)) vars <- sapply(vars, function(z) return(which(colnames(x)==z)))
if(length(vars) < 1) stop("Specified variable names do not match x!")
if(is.null(col)){
k <- max(unique(object$cluster))
if(k > 2) col <- brewer.pal(k, "Set3")
if(k == 2) col <- c("lightblue","orange")
if(k == 1) col <- "lightblue"
}
clusids <- sort(unique(object$cluster))
if(length(col) != max(clusids)) warning("Length of col should match number of clusters!")
#REMOVE PROMPT
#par(ask=TRUE)
par(mfrow=c(2,2))
for(i in vars){
if(is.numeric(x[,i])){
boxplot(x[,i]~object$cluster, col = col, main = colnames(x)[i])
legend("topright", legend=clusids, fill = col)
}
if(is.factor(x[,i])){
tab <- table(x[,i], object$cluster)
for(j in 1:length(object$size)) tab[,j] <- tab[,j]/object$size[j]
barplot(t(tab), beside = TRUE, main = colnames(x)[i], col = col)
}
}
invisible()
}
And then you can call it once without having to hit Enter:
my.clprofiles(kpres,x)
which produces the same plot as in the first answer.
You can override three of the four prompts (but not the first one) since the plotting method is within the clprofiles command. If your goal is just to get all the plots to print on a single plot, this will do it:
library(clustMixType)
# Example from documentation
n <- 100; prb <- 0.9; muk <- 1.5
clusid <- rep(1:4, each = n)
x1 <- sample(c("A","B"), 2*n, replace = TRUE, prob = c(prb, 1-prb))
x1 <- c(x1, sample(c("A","B"), 2*n, replace = TRUE, prob = c(1-prb, prb)))
x1 <- as.factor(x1)
x2 <- sample(c("A","B"), 2*n, replace = TRUE, prob = c(prb, 1-prb))
x2 <- c(x2, sample(c("A","B"), 2*n, replace = TRUE, prob = c(1-prb, prb)))
x2 <- as.factor(x2)
x3 <- c(rnorm(n, mean = -muk), rnorm(n, mean = muk), rnorm(n, mean = -muk), rnorm(n, mean = muk))
x4 <- c(rnorm(n, mean = -muk), rnorm(n, mean = muk), rnorm(n, mean = -muk), rnorm(n, mean = muk))
x <- data.frame(x1,x2,x3,x4)
kpres <- kproto(x, 4)
Then you can make the plot by preparing with par first:
> par(mfrow=c(2,2))
> clprofiles(kpres, x)
Hit <Return> to see next plot:
>
And it produces:
I found another solution that shows the plots in an external window (full screen) and instead of presing "enter" each time, you just have to click
dev.new(width=5,height=4,noRStudioGD = TRUE)
clprofiles(kpres,df)
I have a program at below here, but I wish to make it into a Graphic User Interface in shiny in R. But I am really new to shiny. Here is the code :
#Optimization to find w for a sigmoid with given
#multiple samples for one input and one output
#x1, x2... are different observation for one x input
require(ggplot2)
generate_data<- function(n){
x_neg<- -3L
x_pos<- 3L
scale<- 1.5
n_samples<- n
x_train<- matrix(c(rnorm(n_samples) + x_pos
, rnorm(n_samples) + x_neg)*scale, byrow = T)
y_train<- matrix(c(rep(1, n_samples), rep(0, n_samples)), byrow = T)
list(x_train, y_train)
}
n <- 10
data_train<- generate_data(n)
x_train<- as.matrix(data_train[[1]])
y_train<- as.matrix(data_train[[2]])
plot(x_train, y_train, col='green', pch= 3
, ylim= c((min(y_train)-0.2), (max(y_train)+0.2)))
#create tensor:
unity_matrix<- matrix(rep(1, nrow(x_train)))
x_tensor<- cbind(unity_matrix, x_train)
sigmoid_neuron<- function(x, w) {
output<- 1/(1 + exp(-(x_tensor%*%w)))
}
w<- matrix(rnorm(2), byrow = T)#initialize
(sigmoid_output<- sigmoid_neuron(x= x_tensor, w= w))
points(x_train, sigmoid_neuron(x_tensor, w), col='blue', pch= 19)
Grad<- matrix(rep(0, 2), byrow = T)
compute_gradients<- function(x, y, h) {
Grad[1]<- mean(h- y)
Grad[2]<- mean((h-y)*x)
error<<- (h-y)
return(Grad)
}
compute_gradients(x= x_train, y= y_train, h= sigmoid_output)
##manually cycle through the code chunk to check if the algo works
learningRate<- 0.2
w<- matrix(rnorm(2), byrow = T)#initialize
(sigmoid_output<- sigmoid_neuron(x= x_tensor, w= w))
(grad<- compute_gradients(x_train, y_train, sigmoid_output))
w<- w - learningRate*grad
y_train
##tune sigmoid
learningRate<- 0.2
Grad<- matrix(rep(0, 2), byrow = T)
w<- matrix(rnorm(2), byrow = T)#initialize
idx_end<- 1000
error_history<- list()
for (i in 1:idx_end) {
sigmoid_output<- sigmoid_neuron(x= x_tensor, w= w)
grad<- compute_gradients(x_train, y_train, sigmoid_output)
error_history[[i]]<- error
w<- w - learningRate*grad
}
grad; sigmoid_output; y_train; w
points(x_train, sigmoid_neuron(x_tensor, w), col='red', pch= 4)
error_history_rmse<- sapply(1:length(error_history), function(x) sqrt(mean(error_history[[x]]^2)))
qplot(seq_along(error_history_rmse), error_history_rmse
, ylim = c(0, 0.1)
)
#dev.off()
My problem is, how can I create a Sigmoid Curve (at mainPanel) which I use the sliderInput to adjust the value of idx_end (at the line of 56) on the x-axis?
Here is my code, what should I modify or add to my Server?
library(shiny)
ui <- fluidPage(
sidebarLayout(
sidebarPanel(
sliderInput("x_range", "idx_end",
min = 0, max = 10000, value = c(0, 1000), step = 100)
),
mainPanel(
plotOutput("distPlot"))))
server <- function(input, output, session) {
output$distPlot <- renderPlot({
plot(seq_along(error_history_rmse), error_history_rmse,
xlim = c(0, input$x_range[2]),
#ylim = c(0,0.1),
col = 'darkgray',
border = 'white')})}
shinyApp(ui, server)
Can anyone help me? Really will appreciate it..
You can pretty much just slot in your code into the renderPlot function. Then assign input$x_range[2] to idx_end. However, there's no need to include all of your code in renderPlot, just the code that reacts to user input and makes the plot. Hence, I've placed most of your code in a source R file called 'plot_data.R' then used source to populate the global environment with variables that are static.
library(shiny)
source("plot_data.R")
ui <- fluidPage(
sidebarLayout(
sidebarPanel(
sliderInput("x_range", "idx_end",
min = 0, max = 10000, value = c(0, 1000), step = 100)
),
mainPanel(
plotOutput("distPlot"))))
server <- function(input, output, session) {
output$distPlot <- renderPlot({
learningRate<- 0.2
Grad<- matrix(rep(0, 2), byrow = T)
w<- matrix(rnorm(2), byrow = T)#initialize
idx_end <- input$x_range[2]
error_history<- list()
for (i in 1:idx_end) {
sigmoid_output<- sigmoid_neuron(x= x_tensor, w= w)
grad<- compute_gradients(x_train, y_train, sigmoid_output)
error_history[[i]]<- error
w<- w - learningRate*grad
}
error_history_rmse<- sapply(1:length(error_history), function(x) sqrt(mean(error_history[[x]]^2)))
plot(seq_along(error_history_rmse), error_history_rmse,
xlim = c(0, input$x_range[2]),
#ylim = c(0,0.1),
col = 'darkgray',
border = 'white')})}
shinyApp(ui, server)
I developed a simple shiny app that take as inputs a score my_x on a distribution with mean my_mean and standard deviation my_sd. As output, the app return a Lattice plot with a Normal Standard distribution with the corresponding z-score of my_x. Please find the code for the app on GitHub.
Now, I would like to add a second functionality to the app:
By checking a checkboxInput I would calculate, for example, the pnorm of the inputs and shade the relative area of the graph.
I wrote the code for the graph (here an example of the expected result), but I cannot figure out how to make it work in Shiny. In particular, I cannot figure how to make the function activated with the checkbox working properly with the first function drawing the graph.
library(lattice)
e4a <- seq(60, 170, length = 10000)
e4b <- dnorm(e4a, 110, 15)
#z-score is calculated with the inputs listed above:
z_score <- (my_x - my_mean)/my_sd
plot_e4d <- xyplot(e4b ~ e4a,
type = "l",
main = "Plot 4",
scales = list(x = list(at = seq(60, 170, 10)), rot = 45),
panel = function(x,y, ...){
panel.xyplot(x,y, ...)
panel.abline(v = c(z_score, 110), lty = 2)
xx <- c(60, x[x>=60 & x<=z_score], z_score)
yy <- c(0, y[x>=60 & x<=z_score], 0)
panel.polygon(xx,yy, ..., col='red')
})
print(plot_e4d)
I found a functioning solution. I am pretty sure that it is not the most efficient, but it works. It consists of an if/else statement within the server function calling the plot. I would like to thank #zx8754 for the inspiration.
Here is the ui.r file:
library(shiny)
shinyUI(pageWithSidebar(
headerPanel("Standard Normal"),
sidebarPanel(
numericInput('mean', 'Your mean', 0),
numericInput('sd', 'Your standard deviation', 0),
numericInput('x', 'Your score', 0),
checkboxInput('p1', label = 'Probability of getting a score smaller than x or z', value = FALSE)
),
mainPanel(
h3('Standard Normal'),
plotOutput('sdNorm'),
h4('Your z-score is:'),
verbatimTextOutput('z'),
h4('Your lower tail probability is:'),
verbatimTextOutput('p1')
))
)
And the server.R file:
library(lattice)
shinyServer(
function(input, output){
output$sdNorm <- renderPlot({
dt1 <- seq(-3, 3, length = 1000)
dt2 <- dnorm(dt1, 0, 1)
my_mean <- input$mean
my_sd <- input$sd
my_x <- input$x
z <- (my_x - my_mean)/my_sd
if(input$p1){
xyplot(dt2 ~ dt1,
type = "l",
main = "Lower tail probability",
panel = function(x,y, ...){
panel.xyplot(x,y, ...)
panel.abline(v = c(z, 0), lty = 2)
xx <- c(-3, x[x>=-3 & x<=z], z)
yy <- c(0, y[x>=-3 & x<=z], 0)
panel.polygon(xx,yy, ..., col='red')
})
}else{
xyplot(dt2 ~ dt1,
type = "l",
main = "Standard Normal Distribution",
panel = function(x, ...){
panel.xyplot(x, ...)
panel.abline(v = c(z, 0), lty = 2)
})
}
})
output$z = renderPrint({
my_mean <- input$mean
my_sd <- input$sd
my_x <- input$x
z <- (my_x - my_mean)/my_sd
z
})
output$p1 <- renderPrint({
if(input$p1){
my_mean <- input$mean
my_sd <- input$sd
my_x <- input$x
p1 <- 1- pnorm(my_x, my_mean, my_sd)
p1
} else {
p1 <- NULL
}
})
}
)
This should work:
library(shiny)
library(lattice)
shinyApp(
ui = {
pageWithSidebar(
headerPanel("Standard Normal"),
sidebarPanel(
numericInput('mean', 'Your mean', 80),
numericInput('sd', 'Your standard deviation', 2),
numericInput('x', 'Your score', 250),
checkboxInput("zScoreArea", label = "Area under z-score", value = TRUE)
),
mainPanel(
h3('Standard Normal'),
plotOutput('sdNorm'),
h4('Your z-score is:'),
verbatimTextOutput('z_score')
))
},
server = {
function(input, output){
#data
dt1 <- seq(60, 170, length = 10000)
dt2 <- dnorm(dt1, 110, 15)
#xyplot panel= function()
myfunc <- reactive({
if(input$zScoreArea){
function(x,y, ...){
panel.xyplot(x,y, ...)
panel.abline( v = c(z_score(), 110), lty = 2)
xx <- c(60, x[x >= 60 & x <= z_score()], z_score())
yy <- c(0, y[x >= 60 & x <= z_score()], 0)
panel.polygon(xx,yy, ..., col='red')
}
}else{
function(x, ...){
panel.xyplot(x, ...)
panel.abline(v = c(z_score(), 110), lty = 2)}
}
})
#reactive z_score for plotting
z_score <- reactive({
my_mean <- input$mean
my_sd <- input$sd
my_x <- input$x
#return z score
(my_x - my_mean)/my_sd
})
output$sdNorm <- renderPlot({
xyplot(dt2 ~ dt1,
type = "l",
main = "Plot 4",
scales = list(x = list(at = seq(60, 170, 10)), rot = 45),
panel = myfunc()
)
})
output$z_score = renderPrint({ z_score() })
}
}
)
I need to compute the efficient frontier with different risk measure and to use a bootstrapping technique to simulate possible outcome. However, now I'm stuck: what I want to do is to generate via a loop (which will be integrated later into a function) multiple efficient frontier, each one associated to a possible future outcome, and to plot them on the same figure in such a way to see how they may change as the simulation goes on. Here is the loop that I wrote so far:
for (i in 1:B) {
idx <- sample(1:N, N, replace = TRUE)
new.x <- x[idx, ]
µ.b <- apply(X = new.x, 2, FUN = mean)
range.b[, i] <- seq(from = min(µ.b), to = max(µ.b), length.out = steps)
sigma.b <- apply(X = new.x, 2, FUN = sd)
riskCov.b[, i] <- sapply(range.b[, i], function(targetReturn) {
w <- MV_QP(new.x, targetReturn, Sigma)
sd(c(new.x %*% w))
})
xlim.b <- range(c(sigma.b, riskCov.b[, 1]), na.rm = TRUE)
ylim.b <- range(µ.b)
par(new = TRUE)
plot(x = riskCov.b[, i], y = range.b[, i], type = "l", xlim = xlim.b, ylim = ylim.b, xlab = "Risk", ylab = "Return", main = "Resampling EFs")
}
but the problem is that the elements on the x and y axis are rewriting each time the loop runs. How can this problem be solved?
I don't nknow if the optimization is correct. For ploting you can try the following:
for (i in 1:B) {
idx <- sample(1:N, N, replace = TRUE)
new.x <- x[idx, ]
µ.b <- apply(X = new.x, 2, FUN = mean)
range.b[, i] <- seq(from = min(µ.b), to = max(µ.b), length.out = steps)
#sigma.b <- apply(X = new.x, 2, FUN = sd)
riskCov.b[, i] <- sapply(range.b[, i], function(targetReturn) {
w <- MV_QP(new.x, targetReturn,Sigma=cov(new.x))
sd(c(new.x %*% w))
})
}
xlim.b <- range(c(apply(X = x, 2, FUN= sd), riskCov.b), na.rm = TRUE) *c(0.98,1.02)
ylim.b <- range(µ.b) *c(0.98,1.02)
#par(new = TRUE)
for (i in 1:B){
if (i==1) plot(x = riskCov.b[, i], y = range.b[, i], type = "l", xlim = xlim.b, ylim = ylim.b, xlab = "Risk", ylab = "Return", main = "Resampling EFs") else
lines(x = riskCov.b[, i], y = range.b[, i],col=rainbow(B)[i])
}
Depending on your data, you should end up with a similar plot: