Portfolio Optimization - R solve.QP giving "constraints are inconsistent, no solution" - r

When I run a shiny app for portfolio optimization, I get this error ("constraints are inconsistent, no solution") randomly about half the time, while it seems to work correctly half the time. I'm not really sure where the code is going wrong, as I've run the specific solve.QP and quadprog related commands on the console and it works fine there. It's only when I run it on the shiny app that the issue occurs. I suspect it may have something to do with how the code is processing the input, or with how the meq is defined. But I can't tell for sure. I have looked at similar questions on stack overflow but am unsure of how exactly I should change my meq constraints or make the Dmat matrix symmetric (if those two are the issues).
Here's the code:
library(quantmod)
library(lubridate)
library(dplyr)
library(data.table)
library(quadprog)
library(shiny)
Define UI for application that draws a histogram
ui <- fluidPage(
Application title
titlePanel("Robo-Advisor Shiny App"),
Sidebar with a slider inputs
fluidRow(
column(3,
numericInput(
inputId = "start",
label = "Beginning Date (yyymmdd):",
value = 20160101
),
numericInput(
inputId = "end",
label = "Ending Date (yyymmdd):",
value = 20201231
),
selectInput(
inputId = "parameter",
label = "Return optimal portfolio for given:",
choices = c("mu", "vol"),
selected = "mu"
),
numericInput(
inputId = "desired_annual_expected_return",
label = "Desired annual expected return (in decimal format):",
value = 0.2
),
numericInput(
inputId = "desired_annual_vol",
label = "Desired annual vol (in decimal format):",
value = 0.15
)
),
column(9,align="center",
fluidRow(
#splitLayout(div(plotOutput("prcPlot")), div(tableOutput("titleTable"), style = "font-size:100%"), div(tableOutput("prcTable"), style = "font-size:100%"), cellWidths = c("50%", "50%"))
div(plotOutput("prcPlot")),
div(tableOutput("titleTable")),
div(tableOutput("prcTable"))
)
)
) #close fluidRow
)#close fluidPage
Define server logic required to draw a histogram
server <- function(input, output) {
#####PREPARING DATA FOR PLOT & TABLE FUNCTIONS
dataPrep = reactive ({
#define variables from input boxes--------------------
startdt = ymd(input$start)
enddt = ymd(input$end)
parameter = input$parameter
d_mean = input$desired_annual_expected_return
d_sd = input$desired_annual_vol
#download and organize data---------------------------
symbolList = c("MSFT", "WMT", "AAPL", "IBM", "KO")
getSymbols(symbolList, from = startdt, to = enddt, src="yahoo") #default source is finance.yahoo.com
#Convert to dataframe
MSFT = as.data.frame(MSFT)
WMT = as.data.frame(WMT)
AAPL = as.data.frame(AAPL)
IBM = as.data.frame(IBM)
KO = as.data.frame(KO)
MSFT = to.monthly(MSFT) #converts to monthly frequency
WMT = to.monthly(WMT)
AAPL = to.monthly(AAPL)
IBM = to.monthly(IBM)
KO = to.monthly(KO)
prices = cbind(MSFT$MSFT.Adjusted, WMT$WMT.Adjusted, AAPL$AAPL.Adjusted,
IBM$IBM.Adjusted, KO$KO.Adjusted)
len = dim(prices)[1]
returns = as.data.frame(prices[2:len,] / prices[1:(len-1),]) - 1
names(returns) = c("msft", "wmt", "aapl", "ibm", "ko")
#Define the mean-variance optimization function
QPoptim = function(Eport, noshort, N, muvec, covmat){
ones = array(1,N)
Dmat = covmat
dvec = array(0,N)
Amat = cbind(muvec, ones)
b0vec = c(Eport, 1)
if(noshort==1) {
idmat = matrix(0,N,N)
diag(idmat) = 1
Amat = cbind(Amat,idmat)
b0vec = c(b0vec, array(0,N))
}
wvec = solve.QP(Dmat, dvec, Amat, b0vec, meq=2)$solution
sigport = sqrt( t(wvec) %*% covmat %*% wvec ) #returns this last value
}
#repeating the Qpoptim code partly to get only the portfolio weights
meanvarweights = function(Eport, noshort, N, muvec, covmat){
ones = array(1,N)
Dmat = covmat
dvec = array(0,N)
Amat = cbind(muvec, ones)
b0vec = c(Eport, 1)
if(noshort==1) {
idmat = matrix(0,N,N)
diag(idmat) = 1
Amat = cbind(Amat,idmat)
b0vec = c(b0vec, array(0,N))
}
wvec = solve.QP(Dmat, dvec, Amat, b0vec, meq=2)$solution
}
#initialize
N = 5
muvec = colMeans(returns[,1:N])
covmat = var(returns[,1:N])
#scroll through Eport values to derive efficient frontier
mincut = min(muvec)
maxcut = max(muvec)
Eportvec = seq(mincut,maxcut,length=300)
sigportvec = unlist(lapply(Eportvec, QPoptim, noshort=1, N, muvec, covmat))
#annualize stats
sigportvec = sigportvec * sqrt(12)
Eportvec = Eportvec * 12
#defining efficient frontier---------------------------------------------------
Emincut = Eportvec[which(sigportvec==min(sigportvec))]
idx = which(Eportvec>=Emincut)
#selecting the optimal portfolio
if (parameter=="mu") {
muportvec=c(d_mean)
w1 = meanvarweights(Eport=muportvec[1]/12, noshort=1, N, muvec, covmat)
sig1 = sqrt( t(w1) %*% covmat %*% w1 ) * sqrt(12)
} else {
sigportvec_1 = sigportvec[idx]
Eportvec_1 = Eportvec[idx]
a = which(abs(sigportvec_1-d_sd)==min(abs(sigportvec_1-d_sd)))
muportvec = c(Eportvec_1[a])
w1 = meanvarweights(Eport=(muportvec[1]/12), noshort=1, N, muvec, covmat)
sig1 = sqrt( t(w1) %*% covmat %*% w1 ) * sqrt(12)
}
#return data for output function-----------------------
temp = list(Eportvec = Eportvec, sigportvec = sigportvec,
w1=w1, muportvec=muportvec,sig1=sig1,idx=idx)
})
#####Plotting frontier
output$prcPlot <- renderPlot({
#calls above function for prepped data------------------------------
temp = dataPrep()
sigportvec = temp$sigportvec
Eportvec = temp$Eportvec
muportvec = temp$muportvec
w1 = temp$w1
sig1 = temp$sig1
idx= temp$idx
#define variables from input boxes----------------------------------
startdt = ymd(input$start)
enddt = ymd(input$end)
parameter = input$parameter
d_mean = input$desired_annual_expected_return
d_sd = input$desired_annual_vol
#text heading of plot
startdt_txt = format(startdt, "%Y-%m-%d")
enddt_txt = format(enddt, "%Y-%m-%d")
str1 = "Efficient Frontier (based on data from)"
str2 = "to"
main_text_string = paste(str1,startdt_txt,str2,enddt_txt)
#plots all minimum variance portfolios------------------------------------------
plot(sigportvec, Eportvec,
xlim=c(0,max(sigportvec)), ylim=c(0,max(Eportvec)),
type="l", xlab="sigma", ylab="E(r)",
main=main_text_string, col = "black", lwd=1, lty="dashed")
#now just plot efficient frontier on top------------------------------------------
lines(x=sigportvec[idx], y=Eportvec[idx], type="l", col = "blue", lwd=2)
#point label text
sig1_d = format(round(sig1,2), nsmall = 2)
muportvec_d = format(round(muportvec,2), nsmall = 2)
sig1_t = as.character(sig1_d)
muportvec_t = as.character(muportvec_d)
sig1_txt = paste("sig=",sig1_t)
muportvec_txt = paste("mu=",muportvec_t)
label1 = paste(sig1_txt, ",", muportvec_txt)
#pick a portfolio along efficient frontier-----------------------
points(x=c(sig1), y=muportvec, col="blue", lwd=3, pch=1)
text(x=c(sig1), y=muportvec, labels = c(label1), pos=4)
})
#Making table heading
output$titleTable <- renderTable({
#calls above function for prepped data------------------------------
temp = dataPrep()
sigportvec = temp$sigportvec
Eportvec = temp$Eportvec
muportvec = temp$muportvec
w1 = temp$w1
sig1 = temp$sig1
idx= temp$idx
#define variables from input boxes----------------------------------
startdt = ymd(input$start)
enddt = ymd(input$end)
parameter = input$parameter
d_mean = input$desired_annual_expected_return
d_sd = input$desired_annual_vol
#Prepare table heading format
sig1_d = format(round(sig1,2), nsmall = 2)
muportvec_d = format(round(muportvec,2), nsmall = 2)
if (parameter=="mu") {
string1 <- "The following portfolio achieves your desired annual mu ="
string2 <- "with vol ="
result = paste(string1, muportvec_d, string2, sig1_d)
} else {
string1 <- "The following portfolio achieves your desired annual vol ="
string2 <- "with mu ="
result = paste(string1, sig1_d, string2, muportvec_d)
}
#making table
colnamevec = c(" ")
numcol = length(colnamevec)
blank = array("", numcol)
blank = as.data.frame(t(blank))
colnames(blank) = colnamevec #prepared so that header of output is empty
row1 = blank
row1[1] = c(result)
ltemp = list(row1)
FINALOUT = rbindlist(ltemp) #prints this final table
}, align = 'c')
#####Plotting Summary Table
output$prcTable <- renderTable({
#calls above function for prepped data------------------------------
temp = dataPrep()
sigportvec = temp$sigportvec
Eportvec = temp$Eportvec
muportvec = temp$muportvec
w1 = temp$w1
sig1 = temp$sig1
idx= temp$idx
#define variables from input boxes----------------------------------
startdt = ymd(input$start)
enddt = ymd(input$end)
parameter = input$parameter
d_mean = input$desired_annual_expected_return
d_sd = input$desired_annual_vol
#reducing decimal places in the weight values
w1_d = format(round(w1,2),nsmall=2)
#making table
colnamevec = c(" ", " ")
numcol = length(colnamevec)
blank = array("", numcol)
blank = as.data.frame(t(blank))
colnames(blank) = colnamevec #prepared so that header of output is empty
row1 = blank
row2 = blank
row3 = blank
row4 = blank
row5 = blank
row1[1:2] = c("MSFT",w1_d[1])
row2[1:2] = c("WMT",w1_d[2])
row3[1:2] = c("AAPL",w1_d[3])
row4[1:2] = c("IBM",w1_d[4])
row5[1:2] = c("KO",w1_d[5])
ltemp = list(row1, row2, row3, row4, row5)
FINALOUT = rbindlist(ltemp) #prints this final table
}, align = 'cc')
}
Run the application
shinyApp(ui = ui, server = server)

Related

Error in `V<-`(`*tmp*`, value = `*vtmp*`) : invalid indexing

I used the bibliometrix function in R, and want to plot some useful graphs.
library(bibliometrix)
??bibliometrix
D<-readFiles("E:\\RE\\savedrecs.txt")
M <- convert2df(D,dbsource = "isi", format= "plaintext")
results <- biblioAnalysis(M ,sep = ";" )
S<- summary(object=results,k=10, pause=FALSE)
plot(x=results,k=10,pause=FALSE)
options(width=100)
S <- summary(object = results, k = 10, pause = FALSE)
NetMatrix <- biblioNetwork(M1, analysis = "co-occurrences", network = "author_keywords", sep = ";")
S <- normalizeSimilarity(NetMatrix, type = "association")
net <- networkPlot(S, n = 200, Title = "co-occurrence network",type="fruchterman", labelsize = 0.7, halo = FALSE, cluster = "walktrap",remove.isolates=FALSE, remove.multiple=FALSE, noloops=TRUE, weighted=TRUE)
res <- thematicMap(net, NetMatrix, S)
plot(res$map)
But in the net <- networkPlot(S, n = 200, Title = "co-occurrence network",type="fruchterman", labelsize = 0.7, halo = FALSE, cluster = "walktrap",remove.isolates=FALSE, remove.multiple=FALSE, noloops=TRUE, weighted=TRUE), it shows error
Error in V<-(*tmp*, value = *vtmp*) : invalid indexing
. Also I cannot do the CR, it always shows unlistCR. I cannot use the NetMatrix function neither.
Some help me plsssssssss
The problem is in the data itself not in the code you presented. When I downloaded the data from bibliometrix.com and changed M1 to M (typo?) in biblioNetwork function call everything worked perfectly. Please see the code below:
library(bibliometrix)
# Plot bibliometric analysis results
D <- readFiles("http://www.bibliometrix.org/datasets/savedrecs.txt")
M <- convert2df(D, dbsource = "isi", format= "plaintext")
results <- biblioAnalysis(M, sep = ";")
S <- summary(results)
plot(x = results, k = 10, pause = FALSE)
# Plot Bibliographic Network
options(width = 100)
S <- summary(object = results, k = 10, pause = FALSE)
NetMatrix <- biblioNetwork(M, analysis = "co-occurrences", network = "author_keywords", sep = ";")
S <- normalizeSimilarity(NetMatrix, type = "association")
net <- networkPlot(S, n = 200, Title = "co-occurrence network", type = "fruchterman",
labelsize = 0.7, halo = FALSE, cluster = "walktrap",
remove.isolates = FALSE, remove.multiple = FALSE, noloops = TRUE, weighted = TRUE)
# Plot Thematic Map
res <- thematicMap(net, NetMatrix, S)
str(M)
plot(res$map)

The networkd3 is displaying all data, not the subset I want to show based on widget inputs in Shiny app

I am trying to make a Shiny app where the user selects a few options and a network and data table will display based on the inputs. I have a diet study database and would like users to be able to specify the predator species they are interested in, the diet metric (weight, volumetric, etc) and the taxonomic level they want nodes identified to. The data table works fine (so I did not include the code) and updates based on the input but the network does not change, it only shows all of the data. When I run the code for generating the plot outside of Shiny it works fine. This is my first shiny attempt so any suggestions would be greatly appreciated.
library(dplyr)
library(igraph)
library(networkD3)
Diet <-data.frame(
Predator_Scientific_Name = rep("Acanthocybium solanderi", 10),
Class_Predator = rep("Actinopterygii", 10),
Order_Predator = rep("Perciformes", 10),
Family_Predator = rep("Scombridae", 10),
Genus_Predator = rep("Acanthocybium", 10),
Species_Predator = rep("solandri", 10),
Class_Prey = rep("Actinopterygii", 10),
Order_Prey = c( "Clupeiformes" , NA , "Perciformes", "Perciformes", "Perciformes", "Perciformes", "Perciformes", "Perciformes", "Tetraodontiformes", "Tetraodontiformes"),
Family_Prey = c("Clupeidae", NA, "Coryphaenidae", "Carangidae", "Scombridae","Echeneidae","Carangidae", "Scombridae", "Balistidae","Diodontidae"),
Genus_Prey = c("Sardinella", NA, "Coryphaena", "Decapterus", "Euthynnus", NA, NA, NA, "Balistes", "Diodon"),
Species_Prey = c("aurita" , "", "hippurus", "punctatus","alletteratus", "", "", "","capriscus", "spp." ),
Lowest_Taxonomic_Identification_Prey = c("Sardinella aurita","Actinopterygii","Coryphaena hippurus","Decapterus punctatus","Euthynnus alletteratus", "Echeneidae", "Carangidae","Scombridae","Balistes capriscus","Diodon spp."),
Frequency_of_Occurrence = c(2.8, 59.1, 1.4, 7.0, 1.4, 1.4, 15.5, 21.1, 2.8, 4.2), StringAsFactors = FALSE
)
pred.name <- unique(Diet$Predator_Scientific_Name)
prey.tax <- unique(Diet$Lowest_Taxonomic_Identification_Prey)
#Progress bar function
compute_data <- function(updateProgress = NULL) {
# Create 0-row data frame which will be used to store data
dat <- data.frame(x = numeric(0), y = numeric(0))
for (i in 1:10) {
Sys.sleep(0.25)
# Compute new row of data
new_row <- data.frame(x = rnorm(1), y = rnorm(1))
# If we were passed a progress update function, call it
if (is.function(updateProgress)) {
text <- paste0("x:", round(new_row$x, 2), " y:", round(new_row$y, 2))
updateProgress(detail = text)
}
# Add the new row of data
dat <- rbind(dat, new_row)
}
dat
}
####
# Define UI for application that draws a histogram
ui <- dashboardPage(
skin = "blue",
dashboardHeader(title = "Diet Database"),
dashboardSidebar(
sidebarMenu(
menuItem("Parameters",
tabName = "paramaters",
icon = shiny::icon("bar-chart")))
),
dashboardBody(
tabItems(
tabItem(
tabName = "paramaters",
fluidRow(
shiny::column(
width = 4,
shinydashboard::box(
title = "Predator",
status = "primary",
solidHeader = TRUE,
collapsible = TRUE,
width = NULL,
shiny::helpText("Select a predator to view its connections and prey items:"),
shiny::selectInput(
"pred",
shiny::h5("Predator Scientific Name:"),
c(NA,pred.name))),
shinydashboard::box(
title = "Prey",
status = "primary",
solidHeader = TRUE,
collapsible = TRUE,
width = NULL,
shiny::helpText("Select a prey taxa to view its connections and predators:"),
shiny::selectInput(
"prey",
shiny::h5("Prey Taxa:"),
c(NA,prey.tax))),
shinydashboard::box(
title = "Diet Metric",
status = "primary",
solidHeader = TRUE,
collapsible = TRUE,
width = NULL,
shiny::helpText("Select a diet metric to use:"),
shiny::selectInput(
"dietmetric",
shiny::h5("Diet Metric:"),
c("Frequency of Occurrence" = "Frequency_of_Occurrence",
"Wet Weight" = "Weight",
"Dry Weight" = "Dry_Weight",
"Volume" = "Volume",
"Index of Relative Importance" = "IRI",
"Index of Caloric Importance" = "ICI",
"Number" = "Number"))),
shinydashboard::box(
title = "Taxonomic Level",
status = "primary",
solidHeader = TRUE,
collapsible = TRUE,
width = NULL,
shiny::helpText("Select a taxonomic level of nodes:"),
shiny::selectInput(
"nodetax",
shiny::h5("Taxonomic Level:"),
c("Order" = "Order",
"Family" = "Family",
"Genus" = "Genus",
"Species" = "Species"))),
shinydashboard::box(
title = "Generate Network",
status = "primary",
solidHeader = T,
collapsible = T,
width = NULL,
actionButton("makenet", "Generate")
)
),
#Area for network to be displayed
shiny::column(
width = 8,
shinydashboard::box(
title = "Trophic Network",
status = "primary",
solidHeader = TRUE,
collapsible = FALSE,
width = NULL,
forceNetworkOutput("netplot")
)
)
))
)))
server <- function(input, output, session) {
network.data <- eventReactive(input$makenet, {
edgelist <- Diet %>% filter(Predator_Scientific_Name == input$pred|Lowest_Taxonomic_Identification_Prey == input$prey
) %>% select(
paste(input$nodetax, "Predator", sep = "_"),
Class_Predator,
paste(input$nodetax, "Prey", sep = "_"),
Class_Prey,
input$dietmetric
)
colnames(edgelist) <- c("SourceName",
"SourceClass",
"TargetName",
"TargetClass",
"Weight")
edgelist <- edgelist[complete.cases(edgelist),]
})
output$netplot <- renderForceNetwork( {
network.data()
ig <-igraph::simplify(igraph::graph_from_data_frame(edgelist[,c(1,3,5)], directed = TRUE))
SourceID <- TargetID <- c()
for (i in 1:nrow(edgelist)) {
SourceID[i] <- which(edgelist[i,1] == V(ig)$name)-1
TargetID[i] <- which(edgelist[i,3] == V(ig)$name)-1
}
#Create edgelist that contains source and target nodes and edge weights
edgeList <- cbind(edgelist, SourceID, TargetID)
nodeList <- data.frame(ID = c(0:(igraph::vcount(ig) - 1)),
nName = igraph::V(ig)$name)
#Determine and assign groups based on class
preddf <-
data.frame(SciName = edgelist[, 1], class = edgelist[, 2])
preydf <-
data.frame(SciName = edgelist[, 3], class = edgelist[, 4])
groupsdf <- rbind(preddf, preydf)
groupsdf <- groupsdf %>% mutate(SciName = as.character(SciName),
class = as.character(class))
nodeGroup <- c()
for (i in 1:nrow(nodeList)) {
index <- which(groupsdf[, 1] == nodeList$nName[i])
nodeGroup[i] <- groupsdf[index[1], 2]
}
nodeList <-
cbind(nodeList,
nodeGroup)
progress <- shiny::Progress$new()
progress$set(message = "Generating your network...", value = 0)
# Close the progress when this reactive exits (even if there's an error)
on.exit(progress$close())
# Create a callback function to update progress.
# Each time this is called:
# - If `value` is NULL, it will move the progress bar 1/5 of the remaining
# distance. If non-NULL, it will set the progress to that value.
# - It also accepts optional detail text.
updateProgress <- function(value = NULL, detail = NULL) {
if (is.null(value)) {
value <- progress$getValue()
value <- value + (progress$getMax() - value) / 5
}
progress$set(value = value, detail = detail)
}
# Compute the new data, and pass in the updateProgress function so
# that it can update the progress indicator.
compute_data(updateProgress)
networkD3::forceNetwork(
Links = edgeList,
# data frame that contains info about edges
Nodes = nodeList,
# data frame that contains info about nodes
Source = "SourceID",
# ID of source node
Target = "TargetID",
# ID of target node
Value = "Weight",
# value from the edge list (data frame) that will be used to value/weight relationship amongst nodes
NodeID = "nName",
# value from the node list (data frame) that contains node
Group = "nodeGroup",
# value from the node list (data frame) that contains value we want to use for node color
fontSize = 25,
opacity = 0.85,
zoom = TRUE,
# ability to zoom when click on the node
opacityNoHover = 0.4 # opacity of labels when static
)
})
}
# Run the application
shinyApp(ui = ui, server = server)
I am sharing my fixed code in case it helps someone in the future. I basically just changed the top of the server code.
network.data <- eventReactive(input$makenet, {
Diet %>% filter(Predator_Scientific_Name == input$pred|Lowest_Taxonomic_Identification_Prey == input$prey
) %>% select(
paste(input$nodetax, "Predator", sep = "_"),
Class_Predator,
paste(input$nodetax, "Prey", sep = "_"),
Class_Prey,
input$dietmetric
) %>% rename("SourceName" = paste(input$nodetax, "Predator", sep = "_"),
"SourceClass" = Class_Predator,
"TargetName" = paste(input$nodetax, "Prey", sep = "_"),
"TargetClass" = Class_Prey,
"Weight" = input$dietmetric) %>% na.omit()
})
output$netplot <- renderForceNetwork( {
edgelist <- network.data()

Shiny Error: object 'data_survival_curve' not found

I can not figure out what is wrong with the following code. After running runApp('script.R'), I am getting the following error Error: object 'data_survival_curve' not found. I run debug in RStudio and on line nr 60 this variable is created and it exists till the moment when error comes.
script.R file:
library(shiny)
library(survival)
library(survminer)
library(directlabels)
data <- read.csv('dataset.csv', header = TRUE, sep = ",", fileEncoding="UTF-8")
unique_transplant_years_decreasing <- as.numeric(sort(unique(c(data$transplant_year)), decreasing = TRUE))
krivkaPreziti <- sidebarLayout(
# all inputs for graph survival analysis (krivka preziti)
sidebarPanel(
sliderInput("krivka_preziti_input_years", 'Years:',
min = unique_transplant_years_decreasing[length(unique_transplant_years_decreasing)],
max = unique_transplant_years_decreasing[1],
value = c(unique_transplant_years_decreasing[length(unique_transplant_years_decreasing)],
unique_transplant_years_decreasing[1]),
step = 1),
numericInput('krivka_preziti_input_seskupit_po', 'Group by (years):',
value = 0,
min = 0),
checkboxInput('krivka_preziti_input_facet', 'Facet', value = FALSE),
width = 3
),
# Create a spot for bar plot
mainPanel(
h2('Survival curve'),
br(),
plotOutput('krivka_preziti', height = "750px"),
width = 12
)
)
panelAnalyzaPreziti <- tabPanel(
'Survival analysis',
krivkaPreziti
)
ui <- navbarPage(
title = "Application",
panelAnalyzaPreziti
)
server <- shinyServer(
function(input, output, session)
{
output$krivka_preziti <- renderPlot(
{
krivka_year_bottom <- input$krivka_preziti_input_years[1]
krivka_year_top <- input$krivka_preziti_input_years[2]
krivka_seskupit_po <- input$krivka_preziti_input_seskupit_po
# data which fit the range of selected years
# data which meet the condition that survival_time is not NA
data_survival_curve <- data[data$transplant_year %in% seq(krivka_year_bottom, krivka_year_top) &
!is.na(data$survival_time) &
data$survival_time >= 0,]
# if seskupit_po != 0, then cut
if(krivka_seskupit_po != 0) {
data_survival_curve$time_period <- cut(as.numeric(data_survival_curve$transplant_year),
seq(krivka_year_bottom, krivka_year_top, krivka_seskupit_po),
include.lowest = T)
data_survival_curve <- data_survival_curve[!is.na(data_survival_curve$time_period),]
data_survival_curve$time_period <- as.factor(data_survival_curve$time_period)
}
else {
data_survival_curve$time_period = data_survival_curve$transplant_year
}
# validate number of rows of data set > 0
shiny::validate(
need(nrow(data_survival_curve) > 0, 'Broader your input')
)
surv_obj <- Surv(data_survival_curve$survival_time/365,data_survival_curve$patient_died)
fit <- survfit(surv_obj ~ time_period, data = data_survival_curve)
krivka_preziti_plt <- ggsurvplot(fit,
linetype = c('solid'),
ggtheme = theme_bw(),
surv.scale = 'percent',
xlab = 'Years',
ylab = '%',
censor = FALSE,
break.x.by = 1,
break.y.by = 0.1)
plot2 <- krivka_preziti_plt + geom_dl(aes(label = time_period), method = list("last.points"), cex = 0.8)
plot2
}
)
}
)
shinyApp(
ui = ui,
server = server
)
Here is the data set that I am using: enter link description here
I've been struggling with the same issue since almost 1 hour and finally found the solution !
There have been a change in the "ggsurvplot" function and you now need to specify the dataset used in the "fit" element. So in your code you have to add :
krivka_preziti_plt <- ggsurvplot(fit, data = data_survival_curve,
linetype = c('solid'),
ggtheme = theme_bw(),
surv.scale = 'percent',
xlab = 'Years',
ylab = '%',
censor = FALSE,
break.x.by = 1,
break.y.by = 0.1)
Source : Github Issue, 13th of January 2018

How can I use for loop inside shiny server?

This is my very first question here, can anybody help me to solve this problem? I will really appreciate that!
I am trying to create a vector based on existing vectors. But the for loop inside shiny server didn't work for me. I have tried many ways but still cannot make it.
ui <- (
tabPanel(
"Momentum Analysis",
sidebarPanel(
width = 4,
textInput("ticker2", "Stock ticker:"),
dateRangeInput(
"date2",
"Date Range:",
max = Sys.Date(),
end = Sys.Date(),
startview = "year"
),
numericInput(
"alpha",
"Volatility smoothing parameter:",
min = 0,
max = 1,
value = 0.05
),
numericInput(
"beta",
"Momentum smoothing parameter:",
min = 0,
max = 1,
value = 0.05
),
radioButtons("type2",
"Chart Type:",
c(
"Momentum vs. Volatility" = "mvv",
"Signal to Noise Ratio" = "snr"
)),
actionButton(
"plot2",
"Plot",
icon("line-chart"),
style = "color: #fff;
background-color: #337ab7;
border-color: #2e6da4"
),
div(
style = "display: inline-block;
vertical-align: top",
downloadButton("download2", "Download historical stock price data")
)
),
mainPanel(plotOutput("chart2"))
)
)
)
server <- function(input, output){
stock2 <-
reactive(
getSymbols(
toupper(input$ticker2),
from = as.Date(input$date2[1]) - 150,
to = input$date2[2],
src = "google",
auto.assign = F
)
)
stock3 <- reactive(as.data.table(stock2()))
stock <- reactive(as.data.frame(stock3()))
stock.return <- reactive(diff(log(stock()[, 5])))
stock.mu <- reactive(mean(stock.return()))
stock.var <- reactive((stock.return() - stock.mu()) ^ 2)
stock.var.smoothed <- reactive(rep(0, length(stock.return())))
stock.var.smoothed <- reactive({
for (i in 2:length(stock.var())) {
stock.var.smoothed[1] <- stock.var()[1]
stock.var.smoothed[i] <-
(1 - input$alpha) * stock.var.smoothed()[i - 1] + input$alpha * stock.var()[i]
}
})
stock.std.smoothed <- reactive(sqrt(stock.var.smoothed()))
stock.std.smoothed.annually <- reactive(stock.var.smoothed() * sqrt(252))
stock.momentum <- reactive(stock.return())
stock.momentum.smoothed <- reactive(rep(0, length(stock.return())))
stock.momentum.smoothed <- reactive({
for (i in 2:length(stock.return())) {
stock.momentum.smoothed[1] <- stock.momentum()[1]
stock.momentum.smoothed[i] <-
(1 - input$beta) * stock.momentum.smoothed()[i - 1] + input$beta * stock.return()[i]
}
})
stock.momentum.smoothed.annually <-
reactive(stock.momentum.smoothed() * 252 / 100)
stock.SNR <-
reactive(stock.momentum.smoothed.annually() / stock.std.smoothed.annually())
output$chart2 <- renderPlot({
req(input$plot2)
if (input$type2 == "mvv"){
plot(
stock.momentum.smoothed(),
main = "Momentum v.s. Volatility",
col = "red",
type = "l",
xaxt = "n",
ylab = "Momentum v.s. Volatility",
xlab = "Date",
ylim = c(-2, 2)
)
lines(stock.std.smoothed())
axis(1, at = 1:length(stock()[, 1]), labels = stock()[, 1])
}
else if (input$type2 == "snr"){
plot(
stock.SNR(),
main = "Signal to Noise",
type = "l",
col = "red",
ylim = c(-1, 1),
xaxt = "n",
ylab = "Signal to Noise Ratio",
xlab = "Date"
)
abline(h = 0.5)
axis(1, at = 1:length(stock()[, 1]), labels = stock()[, 1])
}
})
output$download2 <- downloadHandler(
filename = function() {
paste(toupper(input$ticker2),
" ",
input$date2[1],
" ",
input$date2[2],
".xlsx",
sep = "")
},
content = function(file) {
write.xlsx2(stock2()[paste0(input$date2, "/"),], file)
}
)
}
I am trying to plot the stock's momentum vs volatility, both are smoothed. My app has some other tabs but they are irrelevant so I just hided the code.
The only problem here is the loop and the reactive function. Thank you!
Please refer to Konrad Rudolph's answer
For loop inside reactive function in Shiny
I was trying to assign a vector with a function (reactive). But I didn't give any return to that function and so that I cannot call this function.

Shiny crashing when recalculating plot

I'm trying to make a reactive output graph in shiny, but everytime I try to move the slide the whole app crash, and in console I get a [... truncated] message. Here's the code for the UI:
shinyUI(fluidPage(
fluidRow(
column(
width=8, offset=2,
h1("Palabras reguladoras en secuencias no codificantes",align="center",style="padding-top:15px;font-size:28px")
)),
fluidRow(
column(
width=12,
h3(strong("Represión de UTR´s en ratón con microRNA"),
align="center",style="font-size:20px;line-height:10px")
)
),
wellPanel(align = "center", sliderInput("largo", label = h3("Número de bases en la palabra"), min = 1, max = 10, value = 6)),
wellPanel(align = "center", plotOutput("grafica"), tableOutput ("tabla"))
))
And the code for ther server:
shinyServer(function(input, output){
observe({
rm(list=ls())
largo = input$largo
all_arr = colSums(oligonucleotideFrequency(allutrs, width = largo, step = 1))
rep_arr = colSums(oligonucleotideFrequency(represedutrs, width = largo, step = 1))
vector_n = sum(all_arr) - all_arr
tabla = data.frame(rep_arr, all_arr, vector_n, sum(rep_arr))
names(tabla) = c("x", "m", "n", "k")
tabla$hyper = phyper(q = tabla[,1], m = tabla[,2], n = tabla[,3], k = tabla[,4], lower.tail = FALSE)
tabla$hyper_log = -log10(vector)
cuantil = quantile(tabla$hyper_log, probs = 0.99)
tabla$arriba = tabla$hyper_log >= cuantil
centradi = c()
nombres = c()
ia = 0
i = 0
for (i in 1:length(tabla$hyper_log)){
if (tabla[i, "arriba"] == T){
ia = ia + 1
centradi[ia] = tabla$hyper_log[i]
nombres[ia] = row.names(tabla[i,])
}
}
names(centradi) = nombres
#valor_y_graf = tabla[names(centradi),6]
#valor_x_graf = which(tabla$arriba == T)
#partes = list(
#function() plot(tabla$hyper_log, main = "Densidad", xlab = "Palabras", ylab = "Distribución hipergemetrica (-log(10))"),
#function() abline(cuantil,0, col = "red"),
#function() text(valor_x_graf, valor_y_graf, names(centradi), cex=0.6,pos=4, col="blue"))
#output$grafica = renderPlot(for (i in 1:3) partes[[i]]())
output$grafica = renderPlot(plot(tabla$hyper_log))
output$tabla = renderTable(head(tabla))
})
})
I think it is because of the high memory use, especially in the for cycle, because when took it away it run. Is there a way to make this work?

Resources