total_amount <- 1000000
df <- data.frame("price"= c(226,186,456,615,549),
"firms"= c("VRSN","TXN","DPZ","IDXX","ORLY"))
FUN <- function(q, price=df$price){
total <- sum(price * q)
errs <- c( (total-total_amount)^2, ( ( q[1]*price)/sum(q[1]*price+q[2]*price+q[3]*price+q[4]*price+q[5]*price) +
q[2]*price/sum(q[1]*price+q[2]*price+q[3]*price+q[4]*price+q[5]*price) +
q[3]*price/sum(q[1]*price+q[2]*price+q[3]*price+q[4]*price+q[5]*price)
+ q[4]*price/sum(q[1]*price+q[2]*price+q[3]*price+q[4]*price+q[5]*price)
+ q[5]*price/sum(q[1]*price+q[2]*price+q[3]*price+q[4]*price+q[5]*price) ))
sum(errs)
}
init_q <- rep(1,nrow(df))
res <- optim(init_q, FUN, lower=rep(0,nrow(df)), method="L-BFGS-B")
res
res$par
round(res$par)
sum(round(res$par)*df$price) - total_amount
dt <- df$firms %>% as.data.frame()
dt$lot <- round(res$par,0)
dt$price <- df$price
dt$dnm <- dt$lot*dt$price/sum(dt$lot*dt$price)
dt
I wrote a code that minimize the total amount of money that I had, however I also want to be able to assign weights to stocks and make them have shares as integer.
How could I do that ?
Related
I have a task to construct the efficient frontier using 25 portfolios (monthly data). I tired writing a quadprog code for calculating minimum variance portfolio weights for a given expected rate of return. However, regardless of the expected return, the solver values give me the same set weights and variance, which the global minimum variance portfolio. I found the answer using an analytical solution. Attached are the codes:
basedf <- read.csv("test.csv", header = TRUE, sep = ",")
data <- basedf[,2:26]
ret <- as.data.frame(colMeans(data))
variance <- diag(var(data))
covmat <-as.matrix(var(data))
###minimum variance portfolio calculation
Q <- 2*cov(data)
A <- rbind(rep(1,25))
a <- 1
result <- solve.QP(Dmat = Q,
dvec = rep(0,25),
Amat = t(A),
bvec = a,
meq = 1)
w <-result$solution
w
var <- result$value
var
sum(w)
this is another set of codes giving the me same value::
mvp <- function(e,ep){
Dmat <- 2*cov(e)
dvec <- rep(0, ncol(e))
Amat <- cbind(rep(1, ncol(e)), colMeans(e))
bvec <- c(1, ep)
result <- solve.QP(Dmat = Dmat, dvec = dvec, Amat = Amat, bvec = bvec, meq=1)
wp <- result$solution
varP <- result$value
ret_values <- list(wp, varP)
names(ret_values) <- c("wp", "VarP")
return(ret_values)
}
z <- mvp(data, -.005)
z$wp
sum(z$wp)
z$VarP
ef <- function(e, min_e, max_e){
list_e <- seq(min_e,max_e, length=50)
loop <- sapply(list_e, function(x) mvp(e, x)$VarP)
effF <- as.data.frame(cbind(list_e,loop))
minvar <- min(effF$loop)
L <- effF$loop==minvar
minret <- effF[L,]$list_e
minpoint <- as.data.frame(cbind(minret,minvar))
minvarwp <- mvp(e, min_e)$wp
rlist <- list(effF, minpoint, minvarwp)
names(rlist) <- c( "eFF", "minPoint", "wp")
return(rlist)
}
in the efficient frontier, all the 50 portfolios have same level of variance. can anyone tell me whats wrong with solver equation??? thanks.
I tried quadprog but couldnt solve it.
I want to run the optimization function fmincon() over thousands of different input parameters. Briefly, the aim of the optimization is to find the optimal consumption and investment strategy that give the highest utility for a given wealth. The basic set up and functions are given as follows:
library(pracma)
library(NlcOptim)
# individual preference parameters
gamma <- 5
beta <- 0.02
Y <- 1
# financial market parameters
r <- 0.02
mu <- 0.06
sigma <- 0.2
lambda <- (mu-r)/sigma
# Merton fraction
w_star <- lambda / (gamma*sigma)
# fix random seed
set.seed(85)
scenarios <- 1000
Z_omega <- array(rnorm(scenarios,0,1), dim=c(scenarios,1)) # Brownian motion vector for E[J(W)]
# J multiple
multiple <- 1000000000
fineness <- 0.01
# define utility function
u <- function(C) {
C^(1-gamma)/(1-gamma)
}
# wealth scenario at t+1 for a given W_t
W.next <- function(W,C,fstar) {
W.tplus1 <- exp(r + fstar*sigma*lambda - 0.5*fstar^2*sigma^2 + fstar*sigma*Z_omega) * (W + Y - C)
return(W.tplus1)
}
J.simulate <- function(W.tplus1) {
floor.number <- floor((round_any(W.tplus1, fineness, f=floor) * 1/fineness)) + 1
ceiling.number <- ceiling((round_any(W.tplus1, fineness, f=ceiling) * 1/fineness)) + 1
x1 <- G_T[floor.number]
x2 <- G_T[ceiling.number]
y1 <- J_WT[floor.number]
y2 <- J_WT[ceiling.number]
# linear interpolation for J
J.tplus1.simulate <- y1 + ((W.tplus1-x1)/(x2-x1) * (y2-y1))
return(J.tplus1.simulate)
}
# define h(C,f|W)
h_t <- function(Cfstar) {
C <- Cfstar[1]
fstar <- Cfstar[2]
# wealth scenario at t+1 for a given W_t
W.tplus1 <- W.next(W,C,fstar)
# compute indirect utility for simulated W_t+1 using already compute J_WT
J.tplus1.simulate <- J.simulate(W.tplus1) # ignore wealth less than 0.001 (it can never be optimal)
# expectation of all J(W_t+1)
J_t_plus_1 <- mean(J.tplus1.simulate, na.rm=TRUE) # ignore NAs
# function h_t
indirect_utility <- log(-(u(C) + exp(-beta) * J_t_plus_1)*multiple)
return(indirect_utility)
}
For the sake of simplicity, I generated 10 wealth levels, W, to be optimized:
# wealth grid at T
G_T <- c(0.001, seq(0.01, 3, by=0.01))
J_1T <- -291331.95
J_WT <- G_T^(1-gamma) * J_1T
# wealth to be optimized
W_optim <- seq(0.01, 0.1, by=0.01)
What I did using the for loop is as follows:
# number of loop
wealth.loop <- length(W_optim)
# result vectors
C_star <- numeric(wealth.loop)
f_star <- numeric(wealth.loop)
J <- numeric(wealth.loop)
# lowerbound is fixed
lowerbound <- c(0.01,0.0001)
# optimize!
for (g in 1:wealth.loop) {
W <- W_optim[g]
x0 <- c((W+Y)*0.05,w_star) # initial input vector
upperbound <- c(W+Y-0.01,1) # upperbound depending on W
optimization <- fmincon(x0=x0, fn=h_t, lb=lowerbound, ub=upperbound, tol=1e-10)
C_star[g] <- optimization$par[1]
f_star[g] <- optimization$par[2]
J[g] <- optimization$value
print(c(g,optimization$par[1],optimization$par[2]))
}
This works well, but it takes hours to optimize over more than hundred of thousands set of different parameters. Hence, I was looking for some smarter ways of doing this, like using apply-related functions. For instance, I tried:
W <- W_optim
# input matrix
x0 <- matrix(0, nrow=length(W), ncol=2)
x0[,1] <- (W+Y)*0.05
x0[,2] <- w_star
# lowerbound the same
lowerbound <- c(0.01,0.0001)
# upperbound matrix
upperbound <- matrix(0, nrow=length(W), ncol=2)
upperbound[,1] <- W+Y-0.01
upperbound[,2] <- 1
# optimize using mapply
mapply(fmincon, x0=x0, fn=h_t, lb=lowerbound, up=upperbound)
But obviously it doesn't work. I'm not sure whether the problem is using matrix as input parameters, not vector, or I'm just using a wrong function. Is there any way to solve this problem with an efficient & smart coding?
I tried to optimize over the different parameters at once using mapply, but apparently it didn't work. Maybe I should have used another apply-related function or I should make a different structure for the input matrix?
In R/ggplot2 ,when I use geom_bar(stat='identity',position='fill'),
the 'sales' tip show '0.80000',how to change it to '80.0%' ?
(I know mutate a new variable use scales::percent(sales),can work in geom_point)
library(tidyverse)
library(plotly)
test_data <- data.frame(category=c('A','B','A','B'),
sub_category=c('a1','b1','a2','b2'),
sales=c(1,2,4,5))
p <- test_data %>%
ggplot(aes(x=category,y=sales,
fill=sub_category))+
geom_bar(stat='identity',position='fill')
ggplotly(p)
One option (and perhaps the easiest one) would be to compute your percentages manually instead of making use of position = "fill" and create the tooltip manually via the text aesthetic which makes it easy to style the numbers, ... as you like:
library(plotly)
test_data <- data.frame(
category = c("A", "B", "A", "B"),
sub_category = c("a1", "b1", "a2", "b2"),
sales = c(1, 2, 4, 5)
)
test_data <- test_data %>%
group_by(category) %>%
mutate(pct = sales / sum(sales))
p <- test_data %>%
ggplot(aes(x = category, y = pct, fill = sub_category)) +
geom_col(aes(text = paste0(
"category: ", category, "<br>",
"sub_category: ", sub_category, "<br>",
"sales: ", scales::percent(pct)
)))
ggplotly(p, tooltip = "text")
#setwd('Desktop/IE332')
install.packages("wakefield")
install.packages("RMySQL")
install.packages("randomNames")
install.packages('password')
install.packages('OpenRepGrid')
library(RMySQL)
library(password)
library(wakefield)
library(randomNames)
industriesData <- read.csv('Industries.csv')
skills <- read.csv('Skills.csv')
sp500 <- read.csv("http://www.princeton.edu/~otorres/sandp500.csv")
companies <- sample(sp500$Name, 100)
locations <- c('Northwest', 'Midwest', 'Northeast', 'South', 'Southwest', 'Southeast',
'International') # Locations
gpas <- c(4,3.5,3,2.5,2)
n <- 100
locPrefs <- numeric(n)
studentSkills <- matrix(nrow=100,ncol=10)
studentInd <- matrix(nrow=100,ncol=5)
jobSkills <- matrix(nrow=100,ncol=5)
for(j in 1:n){ # Samples random skills assigned to students
studentSkills[j,] <- sample(skills[,1],10,replace=FALSE)
studentInd[j,] <- sample(industriesData[,1],5,replace=FALSE)
jobSkills[j,] <- sample(skills[,1],5,replace=FALSE)
}
studentData <- data.frame('first names'=randomNames(n, which.names = 'first'),'last
names'=randomNames(n, which.names = 'last'),'username'=seq(1,
n),'password'=password(8,numbers=TRUE),'gpa'=gpa(n, mean = 85.356, sd = 3.2, name =
"GPA"),'visa'=sample(c("N","Y"), size = n, replace = TRUE, prob = c(.78, .22)), 'loc
pref'=sample(locations,n,replace = TRUE), 'skill'=studentSkills, 'Industry'=studentInd) # Student data
employerData <- data.frame('company names'=companies, 'pref
gpa'=sample(gpas,n,replace=TRUE), 'sponser?'=sample(c('N','Y'), size=n, replace = TRUE, prob
= c(.78, .22)), 'job id'=sample(seq(100,999),n,replace=FALSE),'pref skill'=jobSkills,
'industry'=sample(industriesData[,1],n,replace=TRUE),'location'=sample(locations,n,replace =
TRUE)) # Employer data
I am trying to send certain columns of the studentData and employerData to tables in SQL, how would i go about doing that? I have a table named students where I would like to upload the first and last names of the studentsData data frame into this SQL table.
To a 3 year old post
ggplot2: facet_wrap strip color based on variable in data set
Baptiste has given the following solution:
d <- data.frame(fruit = rep(c("apple", "orange", "plum", "banana", "pear", "grape")),
farm = rep(c(0,1,3,6,9,12), each=6),
weight = rnorm(36, 10000, 2500),
size=rep(c("small", "large")))
p1 = ggplot(data = d, aes(x = farm, y = weight)) +
geom_jitter(position = position_jitter(width = 0.3),
aes(color = factor(farm)), size = 2.5, alpha = 1) +
facet_wrap(~fruit)
dummy <- ggplot(data = d, aes(x = farm, y = weight))+ facet_wrap(~fruit) +
geom_rect(aes(fill=size), xmin=-Inf, xmax=Inf, ymin=-Inf, ymax=Inf) +
theme_minimal()
library(gtable)
g1 <- ggplotGrob(p1)
g2 <- ggplotGrob(dummy)
gtable_select <- function (x, ...)
{
matches <- c(...)
x$layout <- x$layout[matches, , drop = FALSE]
x$grobs <- x$grobs[matches]
x
}
panels <- grepl(pattern="panel", g2$layout$name)
strips <- grepl(pattern="strip-t", g2$layout$name)
g2$layout$t[panels] <- g2$layout$t[panels] - 1
g2$layout$b[panels] <- g2$layout$b[panels] - 1
new_strips <- gtable_select(g2, panels | strips)
library(grid)
grid.newpage()
grid.draw(new_strips)
gtable_stack <- function(g1, g2){
g1$grobs <- c(g1$grobs, g2$grobs)
g1$layout <- transform(g1$layout, z= z-max(z), name="g2")
g1$layout <- rbind(g1$layout, g2$layout)
g1
}
## ideally you'd remove the old strips, for now they're just covered
new_plot <- gtable_stack(g1, new_strips)
grid.newpage()
grid.draw(new_plot)
(I have just updated the "strip-t" pattern and opened the grid library as it was suggested in the old post)
I repost this because it's an old brillant stuff and I want to use it myself for a presentation.
I'm a beginner in ggplot and this could also help me for various scripts.
Here are my questions :
- How is it possible to choose the color and not to give the same blue and red please? In my script, I have 3 colors to set, and I hope it can be less agressive. Is it possible to do it ?
- Another question, is it possible to integrate this in the legend, i.e to know what are this colors refering ?
Many thanks
you can change the strip colours with the fill scale in the dummy plot. Combining the legends is a bit tricky, but here's a starting point.
library(ggplot2)
library(gtable)
library(gridExtra)
library(grid)
gtable_stack <- function(g1, g2){
g1$grobs <- c(g1$grobs, g2$grobs)
g1$layout <- transform(g1$layout, z= z-max(z), name="g2")
g1$layout <- rbind(g1$layout, g2$layout)
g1
}
gtable_select <- function (x, ...)
{
matches <- c(...)
x$layout <- x$layout[matches, , drop = FALSE]
x$grobs <- x$grobs[matches]
x
}
d <- data.frame(fruit = rep(c("apple", "orange", "plum", "banana", "pear", "grape")),
farm = rep(c(0,1,3,6,9,12), each=6),
weight = rnorm(36, 10000, 2500),
size=rep(c("small", "large")))
p1 = ggplot(data = d, aes(x = farm, y = weight)) +
geom_jitter(position = position_jitter(width = 0.3),
aes(color = factor(farm)), size = 2.5, alpha = 1) +
facet_wrap(~fruit)
dummy <- ggplot(data = d, aes(x = farm, y = weight))+ facet_wrap(~fruit) +
geom_rect(aes(fill=size), xmin=-Inf, xmax=Inf, ymin=-Inf, ymax=Inf) +
theme_minimal() + scale_fill_brewer(palette = "Pastel2")
g1 <- ggplotGrob(p1)
g2 <- ggplotGrob(dummy)
# extract legends
leg <- g1$grobs[[grep("guide-box", g1$layout$name)]]
dummy_leg <- g2$grobs[[grep("guide-box", g2$layout$name)]]
combined_leg <- rbind.gtable(leg, dummy_leg)
g1$grobs[[grep("guide-box", g1$layout$name)]] <- combined_leg
# move dummy panels one cell up
panels <- grepl(pattern="panel", g2$layout$name)
strips <- grepl(pattern="strip-t", g2$layout$name)
g2$layout$t[panels] <- g2$layout$t[panels] - 1
g2$layout$b[panels] <- g2$layout$b[panels] - 1
new_strips <- gtable_select(g2, panels | strips)
# stack new strips on top of gtable
# ideally you'd remove the old strips, for now they're just covered
new_plot <- gtable_stack(g1, new_strips)
grid.newpage()
grid.draw(new_plot)