We have already covered the backtesting of trading strategies in this blog (see Backtest Trading Strategies Like a Real Quant), so let us up the ante: if you want to learn how to backtest

Options trading strategies are strategies where you combine, often several, derivatives instruments to create a certain risk-return profile (more on that here: Financial Engineering: Static Replication of any Payoff Function). Often we want to know how those strategies would fare in the real world.

The problem is that real data on derivatives are hard to come by and/or very expensive. But we help ourselves with a very good proxy: *implied volatility* which is freely available for example for many indices. With that, we can use the good old *Black-Scholes model* to reasonably price options whose strikes are not too far away from the current price of the underlying.

My colleague Professor Michael Stutzer from the University of Colorado demonstrates this in his wonderful paper How Students Can Backtest Madoff’s Claims and we are going to replicate this with R (one of my postgraduate students, Niklas Paulson, was kind enough to update parts of the code which I had written some time ago).

To run the code yourself you would have to install the powerful packages `Quandl`

, `quantmod`

and `PerformanceAnalytics`

(all on CRAN). Additionally, you would have to register at quandl.com to receive your own API key (I will not show mine here for obvious reasons).

library(Quandl) ## Loading required package: xts ## Loading required package: zoo ## ## Attaching package: 'zoo' ## The following objects are masked from 'package:base': ## ## as.Date, as.Date.numeric library(quantmod) ## Loading required package: TTR ## Registered S3 method overwritten by 'quantmod': ## method from ## as.zoo.data.frame zoo ## Version 0.4-0 included new data defaults. See ?getSymbols. library(PerformanceAnalytics) ## ## Attaching package: 'PerformanceAnalytics' ## The following object is masked from 'package:graphics': ## ## legend # get your API key via free registration at quandl.com and insert here Quandl.api_key("XXX")

As an example, the paper backtests the so-called *split strike conversion* strategy which was allegedly pursued by Bernie Madoff’s hedge fund. We will see that this strategy would have fared quite well but unfortunately, it later turned out that Madoff didn’t pursue this strategy after all but had built up a large Ponzi scheme (for more on that: How to Catch a Thief: Unmasking Madoff’s Ponzi Scheme with Benford’s Law).

Anyway, the strategy itself is quite interesting, it consists of

- the purchase of a group or basket of equity securities that are intended to highly correlate to the S&P 100 index,
- the sale of ”out-of-the-money” S&P 100 index call options in an equivalent contract value dollar amount to the basket of equity securities, and
- the purchase of an equivalent number of “out-of-the-money” S&P 100 Index put options

First we have to load all the necessary data and transform them as needed:

# set parameters for out-of-the-money options X <- 0.04 # put 4% OOM Y <- 0.02 # call 2% OOM # calculate S_tp0 (S&P 100 beginning of the month) and S_tp1 (S&P 100 end of the month) getSymbols("^OEX", from = "1990-11-01", to = "2008-11-30", periodicity = "monthly") # values for S_tp0 and S_tp1 ## 'getSymbols' currently uses auto.assign=TRUE by default, but will ## use auto.assign=FALSE in 0.5-0. You will still be able to use ## 'loadSymbols' to automatically load data. getOption("getSymbols.env") ## and getOption("getSymbols.auto.assign") will still be checked for ## alternate defaults. ## ## This message is shown once per session and may be disabled by setting ## options("getSymbols.warning4.0"=FALSE). See ?getSymbols for details. ## [1] "^OEX" S <- coredata(OEX[ , "OEX.Adjusted"]) S_tp0 <- S[-length(S)] # remove last value -> November is only necessary as S_tp1 for October S_tp1 <- S[-1] # remove first value -> starting value of S_tp1 is equal to the end value of S_tp0 # calculate monthly sigma_t (Volatility) getSymbols("^VXO", from = "1990-11-01", to = "2008-10-31", periodicity = "monthly") # Values for implied volatility ## [1] "^VXO" sigma_t <- coredata(VXO[ , "VXO.Adjusted"]) / 100 # calculate values for r_t, see also note 5 on p. 13 yield_t <- Quandl("FRED/TB3MS", trim_start = "1990-11-01", trim_end = "2008-10-31", order = "asc") yield_t <- yield_t[ , "Value"] / 100 P_t <- 100 * (1 - 91/360 * yield_t) r_t <- 4 * log(100/P_t)

We now define the functions for the payoffs of the puts and calls as stated on page 6 of the paper…

Put_t <- function(S_tp0, X, r_t, sigma_t) { d1 <- (log(1/(1-X)) + (r_t + sigma_t^2/2) * 1/12) / (sigma_t*sqrt(1/12)) d2 <- d1 - sigma_t * sqrt(1/12) (1-X) * S_tp0 * exp(-r_t/12) * pnorm(-d2) - S_tp0 * pnorm(-d1) # pnorm is cumulative density function of normal distribution } PutPayoff_tp1 <- function(S_tp0, S_tp1, X) { pmax(0, (1-X) * S_tp0 - S_tp1) } Call_t <- function(S_tp0, Y, r_t, sigma_t) { d1 <- (log(1/(1+Y)) + (r_t + sigma_t^2/2) * 1/12) / (sigma_t * sqrt(1/12)) d2 <- d1 - sigma_t * sqrt(1/12) S_tp0 * pnorm(d1) - (1+Y) * S_tp0*exp(-r_t/12) * pnorm(d2) } CallPayout_tp1 <- function(S_tp0, S_tp1, Y) { pmax(0, S_tp1 - (1+Y) * S_tp0) }

…and finally the function for the actual return of the strike-conversion strategy, i.e. the core of the options strategy backtesting engine:

ROR_t <- function(S_tp0, S_tp1, X, Y, r_t, sigma_t) { (S_tp1 + PutPayoff_tp1(S_tp0, S_tp1, X) - CallPayout_tp1(S_tp0, S_tp1, Y)) / (S_tp0 + Put_t(S_tp0, X , r_t , sigma_t) - Call_t(S_tp0, Y, r_t, sigma_t)) }

Putting it all together and letting the actual backtest run:

strategy_return <- ROR_t(S_tp0, S_tp1, X, Y, r_t,sigma_t) - 1 benchmark_return <- (S_tp1 / S_tp0) - 1 # create a data.frame with both data and with the dates (monthly basis) months <- seq(as.Date("1990-11-1"), by = "month", length = 216) perf <- data.frame(months, strategy_return, benchmark_return) colnames(perf) <- c("months", "Strike-Conversion Strategy", "S&P 100") # create an xts out of the data frame perfxts <- xts(perf[ , -1], order.by = perf[ , 1])

We can now calculate a multitude of performance and risk statistics:

table.Stats(perfxts) ## Strike-Conversion Strategy S&P 100 ## Observations 216.0000 216.0000 ## NAs 0.0000 0.0000 ## Minimum -0.0341 -0.1459 ## Quartile 1 -0.0107 -0.0181 ## Median 0.0174 0.0098 ## Arithmetic Mean 0.0083 0.0057 ## Geometric Mean 0.0080 0.0048 ## Quartile 3 0.0273 0.0320 ## Maximum 0.0338 0.1079 ## SE Mean 0.0015 0.0029 ## LCL Mean (0.95) 0.0053 0.0000 ## UCL Mean (0.95) 0.0112 0.0115 ## Variance 0.0005 0.0018 ## Stdev 0.0222 0.0426 ## Skewness -0.6451 -0.5578 ## Kurtosis -1.0751 1.0153 table.DownsideRisk(perfxts) ## Strike-Conversion Strategy S&P 100 ## Semi Deviation 0.0175 0.0321 ## Gain Deviation 0.0085 0.0244 ## Loss Deviation 0.0110 0.0314 ## Downside Deviation (MAR=10%) 0.0176 0.0334 ## Downside Deviation (Rf=0%) 0.0131 0.0293 ## Downside Deviation (0%) 0.0131 0.0293 ## Maximum Drawdown 0.1555 0.5078 ## Historical VaR (95%) -0.0311 -0.0724 ## Historical ES (95%) -0.0323 -0.0973 ## Modified VaR (95%) -0.0325 -0.0698 ## Modified ES (95%) -0.0347 -0.1005

Interestingly enough, the strike-conversion strategy yielded about the same mean return as the returns reported by Mr. Madoff… but with much bigger volatility (a.k.a. risk).

This was one of the tricks of Madoff to lull his investors into a sense of safety by not reporting over-the-top returns but “only” manipulating the price swings. His equity curve looked like being drawn with a ruler, which is of course totally unrealistic for an investment with this level of return.

A now for the big finale, the performance summary plot, which consists of the equity curves, the monthly returns, and the drawdowns…

charts.PerformanceSummary(perfxts)

…the relative performance plot…

chart.RelativePerformance(perfxts[ , 1], perfxts[ , 2])

…and the risk-return scatterplot:

chart.RiskReturnScatter(perfxts)

As you can see, the risk-return profile of the strike-conversion strategy is much better than that of the underlying index.

With this template you will now be able to backtest different options strategies of your own, you only have to modify `ROR_t`

accordingly. I am looking forward to your insights and feedback in general in the comments.

BTW: I replicated another fascinating paper by Professor Stutzer: Parrondo’s Paradox in Finance: Combine two Losing Investments into a Winner.

**DISCLAIMER**

*This post is written on an “as is” basis for educational purposes only and comes without any warranty. The findings and interpretations are exclusively those of the author and are not endorsed by or affiliated with any third party.*

In particular, this post provides no investment advice! No responsibility is taken whatsoever if you lose money.

*(If you gain money though I would be happy if you would buy me a coffee… that is not too much to ask, is it? )*

Wikipedia defines

A combination of losing strategies becomes a winning strategy.

If you want to learn more about this fascinating topic and see an application in finance, read on!

Please have a look at this wonderful little video by my colleague Professor Humberto Barreto from DePauw University, Indiana, based on a now-defunct app from Alexander Bogomolny of the well-known maths site “Cut the Knot”. It illustrates the general idea of Parrondo’s paradox in about 2 minutes:

Now, imagine that we could do something similar in finance: combine two losing investments into a winner! My colleague Professor Michael Stutzer from the University of Colorado published a fascinating paper which does just that: The Paradox of Diversification. We will reproduce the analytical results of the paper by simulation with real market data. You will see how super easy and intuitive this can be done in R!

In the paper Stutzer uses actual data of the stock market and builds a simple *binomial tree* model with it. Binomial trees are something like the workhorse of quantitative finance (mainly in the area of option pricing). They trace the potential price evolution in discreet up- and down-steps for n periods:

We can easily translate that into an R function which simulates a sample path for given values of `u`

, `d`

and `n`

:

binomial_tree <- function(u, d, n = 30) { prod(sample(c(1+u, 1-d), n, replace = TRUE)) }

As can be seen in Note 1 of the paper (p. 8) market conditions of 6% expected real return and 40% volatility translate into *u* = 0.46 and *d* = 0.34 (*p* is assumed to be 0.5, i.e. up and down movements with those parameters are deemed to be equally probable).

Let us simulate 10,000 sample paths for 30 years and calculate the average return. It can be argued that the *median return* is the right measure here because we are more interested in the real return of an average outcome than in a hypothetical mixture of all possible outcomes (which would be the *arithmetic mean*):

median(replicate(1e4, binomial_tree(u = 0.46, d = 0.34))) ## [1] 0.5733923

The median return of the stock market is negative (-43% as the tree always starts at 1!). With its ups and downs, it would represent the green (“flashing”) game B in the above video. Game A (“regular”) would be Treasury Bills (a so-called “risk-free” asset) with a real return rate of -10 basis points (BPS), i.e. -0.001% (negative real return because of inflation!).

We now combine both negative investment strategies by putting 50% of our money in each. At the beginning of each year we will rebalance the portfolio, so that the initial ratio is restored. We adapt *u* and *d* accordingly, rebalance the portfolio at the beginning of each of the 30 years and again simulate 10,000 sample paths:

median(replicate(1e4, binomial_tree(u = (0.46-0.001)/2, d = (0.34+0.001)/2))) ## [1] 1.343303

Indeed, we got a huge surplus of over 34% this time! *Diversification maintained by rebalancing* (a.k.a. “rebalancing premium” or “volatility pumping”) is Parrondo’s paradox in action!

**DISCLAIMER**

*This post is written on an “as is” basis for educational purposes only and comes without any warranty. The findings and interpretations are exclusively those of the author and are not endorsed by or affiliated with any third party.*

In particular, this post provides no investment advice! No responsibility is taken whatsoever if you lose money.

In data science, we try to find, sometimes well-hidden, patterns (= signal) in often seemingly random data (= noise).

In many an application, we rely on randomness. The problem is that a Turing machine, the theoretical foundation of every computer, knows no randomness. We need to create something *that looks like* randomness out of determinism. There are at least three questions hidden within:

- What is
*true*randomness? - What does “look like” mean in this context?
- Which
*data generating processes*can be used in practice?

As you can imagine this is a huge topic and you can think about and do research on those topics for the rest of your remaining life. So, we leave number one to philosophy (and perhaps to a later post), will give a few hints on number two, and will foremost encounter a practical algorithm that is actually used to achieve number three and program it in R!

Normally users don’t think much about these topics but start to wonder what the `set.seed()`

function is for. When I start to explain to my students that you can reproduce the exact same sequence of random numbers by setting a certain seed they mostly look at me as if I had lost my mind. The concept “exact same sequence of random numbers” just doesn’t make sense to them… and yet it is true:

set.seed(42); (u1 <- runif(30)) ## [1] 0.91480604 0.93707541 0.28613953 0.83044763 0.64174552 0.51909595 ## [7] 0.73658831 0.13466660 0.65699229 0.70506478 0.45774178 0.71911225 ## [13] 0.93467225 0.25542882 0.46229282 0.94001452 0.97822643 0.11748736 ## [19] 0.47499708 0.56033275 0.90403139 0.13871017 0.98889173 0.94666823 ## [25] 0.08243756 0.51421178 0.39020347 0.90573813 0.44696963 0.83600426 set.seed(42); (u2 <- runif(30)) ## [1] 0.91480604 0.93707541 0.28613953 0.83044763 0.64174552 0.51909595 ## [7] 0.73658831 0.13466660 0.65699229 0.70506478 0.45774178 0.71911225 ## [13] 0.93467225 0.25542882 0.46229282 0.94001452 0.97822643 0.11748736 ## [19] 0.47499708 0.56033275 0.90403139 0.13871017 0.98889173 0.94666823 ## [25] 0.08243756 0.51421178 0.39020347 0.90573813 0.44696963 0.83600426 identical(u1, u2) ## [1] TRUE

One way to illustrate this idea is to build a pseudorandom number generator (PRNG) ourselves. An especially simple one is a so-called *Linear Congruential Generator (LCG)*. To generate a new random number you use this simple *recurrence relation*:

is our new random number, which is created out of the random number before that (or the seed to create the first random number). , and are predefined values and is just the remainder of the division by (`%%`

in R).

The mathematical theory of how to choose good values for , and is beyond this post. “Good” means that the generated random numbers actually “look” random. Some important criteria for that are:

- Uniformity of distribution for large quantities of generated numbers.
- Uncorrelatedness of successive values.
- No repetion of sequences of numbers.

Those are ideals no pseudorandom generator can reach but some are better than others in this regard. Ours is not particularly great but simple and relatively fast, so without further ado, we are going to build it in R. Actually we will build two different versions based on a task given by Rosetta Code, where I also posted my solution (for details see: Rosetta Code: Linear congruential generator). To be able to cope with very big integers that can occur during the intermediate steps of the calculation we use the `gmp`

package (on CRAN):

library(gmp) # for big integers ## ## Attaching package: 'gmp' ## The following objects are masked from 'package:base': ## ## %*%, apply, crossprod, matrix, tcrossprod rand_BSD <- function(n = 1) { a <- as.bigz(1103515245) c <- as.bigz(12345) m <- as.bigz(2^31) x <- rep(as.bigz(0), n) x[1] <- (a * as.bigz(seed) + c) %% m i <- 1 while (i < n) { x[i+1] <- (a * x[i] + c) %% m i <- i + 1 } as.integer(x) } seed <- 0 rand_BSD(10) ## [1] 12345 1406932606 654583775 1449466924 229283573 1109335178 ## [7] 1051550459 1293799192 794471793 551188310 rand_MS <- function(n = 1) { a <- as.bigz(214013) c <- as.bigz(2531011) m <- as.bigz(2^31) x <- rep(as.bigz(0), n) x[1] <- (a * as.bigz(seed) + c) %% m i <- 1 while (i < n) { x[i+1] <- (a * x[i] + c) %% m i <- i + 1 } as.integer(x / 2^16) } seed <- 0 rand_MS(10) ## [1] 38 7719 21238 2437 8855 11797 8365 32285 10450 30612

In the second version (used by Microsoft) the results are divided by 65536 so that the created numbers lie in a range between 0 and 32767.

To create random numbers between 0 and 1 we just divide by 32767:

runif_MS <- function(n = 1) { rand_MS(n) / 32767 } boxplot(runif_MS(1000))

This seems to work pretty well. Sometimes we don’t want uniform random numbers but another distribution, most often normally distributed ones. The following illustration from Attilio Meucci’s excellent book “Risk and Asset Allocation” shows that this could easily be done by a mathematical transformation via the *quantile function* (here ) of the respective distribution:

In R:

rnorm_MS <- function(n = 1) { qnorm(runif_MS(n)) } rand_NV <- rnorm_MS(2000) hist(rand_NV)

Not too bad… the Q-Q Plot, which compares the generates numbers to the real normal distribution, corroborates this:

qqnorm(rand_NV)

I hope you enjoyed our little journey from determinism via uniform to normally distributed (pseudo-)random numbers… in case you are still thinking about the question at the beginning (What is *true* randomness?), I have something for you to end this post:

During our little break, Valentine’s Day was celebrated. Yet for many, it was a depressing day because they are single and are looking for love.

Speed dating is a popular format (in times of Covid-19 also in virtual form) to meet many different potential soul mates in a short period of time. If you want to learn which factors determine “getting to the next round”, read on!

As you know by now we won’t just speculate and present anecdotal evidence but base our analysis on hard data. In this case, we take a speed dating data set from my colleagues Professor Andrew Gelman (Columbia University) and Professor Jeniffer Hill (New York University) as provided in the `Lock5withR`

package (on CRAN). From the documentation:

Participants were students at Columbia’s graduate and professional schools, recruited by mass email, posted fliers, and fliers handed out by research assistants. Each participant attended one speed dating session, in which they met with each participant of the opposite sex for four minutes. Order and session assignments were randomly determined. After each four-minute “speed date” participants filled out a form rating their date on a scale of 1-10 on various attributes. Only data from the first date in each session is recorded here

The dataset comprises the following 18 feature variables…

`LikeM`

How much the male likes his partner (1-10 scale)`LikeF`

How much the female likes her partner (1-10 scale)`PartnerYesM`

Male’s estimate of chance the female wants another date (1-10 scale)`PartnerYesF`

Female’s estimate of chance the male wants another date (1-10 scale)`AgeM`

Male’s age (in years)`AgeF`

Females age (in years)`RaceM`

Male’s race: Asian, Black, Caucasian, Latino, or Other`RaceF`

Female’s race: Asian, Black, Caucasian, Latino, or Other`AttractiveM`

Male’s rating of female’s attractiveness (1-10 scale)`AttractiveF`

Female’s rating of male’s attractiveness (1-10 scale)`SincereM`

Male’s rating of female’s sincerity (1-10 scale)`SincereF`

Female’s rating of male’s sincerity (1-10 scale)`IntelligentM`

Male’s rating of female’s intelligence (1-10 scale)`IntelligentF`

Female’s rating of male’s intelligence (1-10 scale)`FunM`

Male’s rating of female as fun (1-10 scale)`FunF`

Female’s rating of male as fun (1-10 scale)`AmbitiousM`

Male’s rating of female’s ambition (1-10 scale)`AmbitiousF`

Female’s rating of male’s ambition (1-10 scale)`SharedInterestsM`

Male’s rating of female’s shared interests (1-10 scale)`SharedInterestsF`

Female’s rating of male’s shared interests (1-10 scale)

…and 2 target variables:

`DecisionMale`

Would the male like another date? Yes or No`DecisionFemale`

Would the female like another date? Yes or No

Without further ado let us fire up our by now well known `OneR package`

(on CRAN) to get right into the matter:

library(OneR) library(Lock5withR) data("SpeedDating") data <- SpeedDating[-c(1, 2)] OneR(optbin(DecisionMale ~., data = data, method = "infogain"), verbose = TRUE) ## Warning in optbin.data.frame(x = data, method = method, na.omit = na.omit): 76 ## instance(s) removed due to missing values ## Warning in OneR.data.frame(optbin(DecisionMale ~ ., data = data, method = ## "infogain"), : data contains unused factor levels ## ## Attribute Accuracy ## 1 * AttractiveM 78% ## 2 LikeM 72% ## 3 PartnerYesM 64% ## 4 SharedInterestsM 63% ## 5 FunM 60.5% ## 6 AmbitiousM 59% ## 7 PartnerYesF 58.5% ## 8 AgeM 57% ## 8 RaceF 57% ## 10 AttractiveF 56.5% ## 10 IntelligentM 56.5% ## 12 IntelligentF 56% ## 13 AmbitiousF 55.5% ## 14 AgeF 55% ## 14 RaceM 55% ## 14 FunF 55% ## 17 LikeF 54.5% ## 17 SincereM 54.5% ## 17 SincereF 54.5% ## 17 SharedInterestsF 54.5% ## 17 DecisionFemale 54.5% ## --- ## Chosen attribute due to accuracy ## and ties method (if applicable): '*' ## ## Call: ## OneR.data.frame(x = optbin(DecisionMale ~ ., data = data, method = "infogain"), ## verbose = TRUE) ## ## Rules: ## If AttractiveM = (1.99,6] then DecisionMale = No ## If AttractiveM = (6,10] then DecisionMale = Yes ## ## Accuracy: ## 156 of 200 instances classified correctly (78%)

We can see that when it comes to men *attractiveness* is the main predictor. It is even more important than how much he likes her, which comes in second place. The third feature (`PartnerYesM`

Male’s estimate of chance the female wants another date) is particularly interesting:

OneR(optbin(DecisionMale ~ PartnerYesM, data = data, method = "infogain")) ## Warning in optbin.data.frame(x = data, method = method, na.omit = na.omit): 4 ## instance(s) removed due to missing values ## ## Call: ## OneR.data.frame(x = optbin(DecisionMale ~ PartnerYesM, data = data, ## method = "infogain")) ## ## Rules: ## If PartnerYesM = (-0.01,5] then DecisionMale = No ## If PartnerYesM = (5,10] then DecisionMale = Yes ## ## Accuracy: ## 180 of 272 instances classified correctly (66.18%)

It shows that even his expectation of the woman wanting another date with him leads to him wanting another date with her! If you show interest in a potential partner this interest will be reciprocated!

All the other features like intelligence, sincerity, fun, shared interests but also age and race are not very good at predicting the outcome of the date.

Ok, in a way this didn’t come as a surprise, everybody knows that men are superficial beings who only look at the outer qualities of a woman. Surely women will look more at inner values, like intelligence, sincerity, or at least shared interests, right? Let’s have a look:

OneR(optbin(DecisionFemale ~., data = data, method = "infogain"), verbose = TRUE) ## Warning in optbin.data.frame(x = data, method = method, na.omit = na.omit): 76 ## instance(s) removed due to missing values ## Warning in OneR.data.frame(optbin(DecisionFemale ~ ., data = data, method = ## "infogain"), : data contains unused factor levels ## ## Attribute Accuracy ## 1 * AttractiveF 73.5% ## 2 LikeF 68.5% ## 2 FunF 68.5% ## 4 PartnerYesF 66.5% ## 5 SharedInterestsF 66% ## 6 PartnerYesM 62.5% ## 7 AmbitiousM 61.5% ## 8 SincereM 59% ## 8 IntelligentF 59% ## 10 IntelligentM 58.5% ## 10 FunM 58.5% ## 12 LikeM 58% ## 12 AttractiveM 58% ## 12 SharedInterestsM 58% ## 15 AgeF 57.5% ## 16 RaceF 56% ## 17 RaceM 55% ## 18 AgeM 54.5% ## 18 SincereF 54.5% ## 18 AmbitiousF 54.5% ## 18 DecisionMale 54.5% ## --- ## Chosen attribute due to accuracy ## and ties method (if applicable): '*' ## ## Call: ## OneR.data.frame(x = optbin(DecisionFemale ~ ., data = data, method = "infogain"), ## verbose = TRUE) ## ## Rules: ## If AttractiveF = (0.991,6] then DecisionFemale = No ## If AttractiveF = (6,10] then DecisionFemale = Yes ## ## Accuracy: ## 147 of 200 instances classified correctly (73.5%)

Oh dear, the same result. The most important quality to getting to the next level is yet again the attractiveness and the order of the following features is more or less the same, with the notable exception of `FunF`

Female’s rating of male as fun:

OneR(optbin(DecisionFemale ~ FunF, data = data, method = "infogain")) ## Warning in optbin.data.frame(x = data, method = method, na.omit = na.omit): 6 ## instance(s) removed due to missing values ## ## Call: ## OneR.data.frame(x = optbin(DecisionFemale ~ FunF, data = data, ## method = "infogain")) ## ## Rules: ## If FunF = (0.991,6] then DecisionFemale = No ## If FunF = (6,10] then DecisionFemale = Yes ## ## Accuracy: ## 186 of 270 instances classified correctly (68.89%)

So, to summarize: attractiveness is the most important quality, yet you only have limited control over it. But not all is lost if you keep the following in mind: if you are a woman signal that you are interested in the guy, and if you are a guy try to be fun!

If all goes well you should also read my post on the final step: The One Question you should ask your Partner before Marrying!

]]>When you ask successful people for their advice on how to become successful you will often hear that you have to take risks, often huge risks.

In this post we will examine whether this is good advice with a simple multi-agent simulation, so read on!

The following quotes from Dan Pierce are only two examples of a wealth of similar advice:

I am not where I am because of luck. I am where I am because I took risks others weren’t willing to take. The world rewards the risk-takers. It always has. It always will.

and

Only those willing to truly risk everything will gain everything. No person ever rose to greatness without the willingness to lose it all.

In a former post, we already found out with the help of a computer simulation that the distribution of wealth in the real world is indistinguishable from a distribution that is solely based on luck (see: The Rich didn’t earn their Wealth, they just got Lucky), here we will go one step further and actually simulate two types of agents: risk-takers (*Risktakers*) and “normal” people (*Normals*).

In every transaction Risktakers always risk all they possess, only limited by what their counterpart is willing to risk. Normals only risk up to 10% of their wealth. For the sake of comparability, we assume that all agents are equally skilled, so their only differentiator is their respective willingness to take risks.

It also means that when nobody is any better than the other the result of every transaction is purely based on luck. In this way, we make sure to isolate the sole effect of risk-taking and don’t mix it up with other qualities.

We are starting with 10,000 agents with an initial wealth of 1,000 units each. 10% of those are Risktakers, the rest are Normals. They conduct 2 million transactions with each other (NB: the simulation will take some time to run!):

w <- 1000 # initial wealth s <- 10000 # population size N <- 2e6 # no of transactions set.seed(1234) P <- rep(w, s) # creating population p_rt <- 0.1 # proportion risk takers max_ra <- 1 # risk appetite of Risktakers, 1 = 100% n_ra <- 0.1 # risk appetite of Normals names(P) <- c(rep(max_ra, p_rt*s), rep(n_ra, (1-p_rt)*s)) # risk appetite for (i in seq_len(N) { who <- sample(s, size = 2) # draw two agents for the transaction profit <- min(as.numeric(names(P[who[1]]))*P[who[1]], as.numeric(names(P[who[2]]))*P[who[2]]) luck <- sample(c(1, 2)) # who comes in first wins the profit! P[who[luck[1]]] <- P[who[luck[1]]] + profit P[who[luck[2]]] <- P[who[luck[2]]] - profit } Risktakers <- P[1:(p_rt*s)] Normals <- P[(p_rt*s+1):s] summary(Risktakers) ## Min. 1st Qu. Median Mean 3rd Qu. Max. ## 0.0 0.0 0.0 959.1 0.0 62525.8 summary(Normals) ## Min. 1st Qu. Median Mean 3rd Qu. Max. ## 0.181 92.055 385.436 1004.545 1322.948 12550.787

Just looking at the max values it seems that risk-taking really pays off bigly! The richest guy in town, with over 60,000 units, is a Risktaker! He increased his wealth more than sixtyfold! The richest Normal only has a comparable meager twelve thousand units. Risktaker beats Normal more than fivefold!

But wait, there is more…

Looking at the quartiles reveals that within the respective groups, wealth is distributed extremely unequally. Because the simulation is a zero-sum game the means are at about the initial wealth (Risktakers are a little bit lower but this is due to chance and can vary in different runs).

Yet all of the displayed quartiles of the Risktakers are zero! Let us visualize this with some boxplots and histograms:

par_bkp <- par(mfrow = c(1, 2)) # plot two plots side-by-side boxplot(Risktakers, main = "Boxplot of Risktakers") boxplot(Normals, main = "Boxplot of Normals")

hist(Risktakers, col = "red") hist(Normals, col = "red") par(par_bkp)

As you can again see, the distribution of wealth is extremely skewed a.k.a. fat-tailed in both cases but dramatically more so within the Risktaker’s group (as one can see in the boxplot, the outliers literally crush the rest of the rest of the distribution)! Where does this leave us for the overall population? Well, let’s have a look at the wealthiest one hundred agents:

head(sort(P, decreasing = TRUE), 100) ## 1 1 1 1 1 1 1 1 ## 62525.762 44291.214 42917.925 40677.429 31761.799 27872.380 23929.614 22753.382 ## 1 1 1 1 1 1 1 1 ## 22458.062 22030.760 21756.148 21544.639 20970.771 20688.107 19473.726 19060.899 ## 1 1 1 1 1 1 1 1 ## 18342.086 18235.872 17411.690 16657.627 16277.219 16040.849 15266.584 14974.140 ## 1 1 1 1 1 1 1 1 ## 14156.247 14074.310 13847.214 13801.259 13729.240 13269.559 12951.397 12678.964 ## 0.1 0.1 1 1 0.1 1 0.1 1 ## 12550.787 12292.314 12002.368 11880.507 11715.641 11353.729 11193.644 10565.727 ## 1 1 1 1 1 0.1 0.1 0.1 ## 10532.670 10432.977 10385.944 10325.536 10266.249 10234.399 10178.293 9997.527 ## 0.1 1 0.1 0.1 0.1 0.1 1 0.1 ## 9995.841 9949.251 9834.962 9631.738 9439.200 9421.867 9359.496 9228.859 ## 0.1 1 0.1 0.1 0.1 0.1 1 0.1 ## 9224.529 9100.988 9029.623 9010.158 8910.210 8834.733 8711.897 8593.258 ## 0.1 0.1 0.1 0.1 0.1 0.1 0.1 1 ## 8543.662 8499.000 8404.759 8381.012 8373.831 8224.851 8190.105 8128.396 ## 0.1 0.1 0.1 0.1 0.1 0.1 0.1 0.1 ## 8107.256 8082.884 8080.619 8034.135 8033.168 7969.405 7955.725 7853.086 ## 0.1 0.1 0.1 0.1 0.1 0.1 0.1 0.1 ## 7809.438 7808.043 7778.937 7778.018 7759.078 7717.847 7681.713 7681.675 ## 0.1 1 0.1 0.1 0.1 0.1 0.1 0.1 ## 7671.718 7656.077 7654.444 7633.274 7617.269 7606.583 7562.145 7532.091 ## 0.1 0.1 0.1 0.1 ## 7518.953 7498.719 7483.523 7450.844

The top 30 comprises exclusively risk-takers (labeled `1`

for 100% risk appetite) but…

tail(sort(P, decreasing = TRUE), 100) ## 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 ## 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 ## 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 ## 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 ## 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 ## 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0

…the bottom 100 are also exclusively risk-takers! In fact it is even worse:

length(Risktakers[Risktakers == 0]) / (p_rt*s) # proportion of broke Risktakers ## [1] 0.928

Over 90% of all Risktakers are broke! No Normal is broke by definition (risking only 10% of anything can never amount to zero!).

Finally, how many agents in each group have increased their initial wealth?

length(Risktakers[Risktakers > 1000]) ## [1] 70 length(Normals[Normals > 1000]) # a lot more Normals who have increased their initial wealth than Risktakers ## [1] 2765

Only 70 Risktakers but nearly 2,800 Normals!

All of this brings us to a very, very important lesson: **If you want to find a formula for success don’t only look at successful people! Look at the losers too and try to find differences in their behaviour!**

Yet everybody only looks at the winners, the stars, the celebs, the super-rich, the centenarians (and the list goes on and on) to find the magic formula but the insight gained is equal to zero by design:

We already learned in the above-mentioned post (The Rich didn’t earn their Wealth, they just got Lucky) that this fallacy of looking only at the winners has a name, it is called *survivorship bias* (and by our simulation, we can understand this name now).

To summarize let me make a little adjustment to the above quote:

Only those willing to truly risk everything will

~~gain everything. No person ever rose to greatness without the willingness to~~(most probably) lose it all.

BTW: Successful people share and comment on my posts a lot!

We will be taking a little break and will be back on March 16, 2021!

]]>The German news magazine DER SPIEGEL has a regular puzzle section in its online version, called “Rätsel der Woche” (“Riddle of the Week”). Some of those puzzles are quite interesting but I am often too lazy to solve them analytically.

So I often kill two birds with one stone: having fun solving the puzzle with R and creating some new teaching material for my R classes! This is what we will do with one of those more interesting riddles, which is quite hard to solve analytically but relatively easy to solve with R, so read on!

The riddle goes like this (source: Wie viele Schließfächer stehen offen?):

We are standing in front of 100 lockers arranged side by side, all of which are closed. One man has a bunch of keys with all 100 keys and will pass the lockers exactly a hundred times, opening or closing some of them.

On the first pass, he opens all the lockers. On the second pass, the man will go to every other locker and change its state. That means: If it is closed, it will be opened. If it is already open, it will be closed. In this case, he closes lockers 2, 4, 6… 98 and 100, because all doors were open before.

On the third pass, he changes the state of every third locker – that is, 3, 6, 9, … 96, 99. Closed doors are opened, open doors closed. In the fourth pass, every fourth locker is changed, at the fifth every fifth – and so on. At the last, the 100th, the man finally only changes the state of door number 100.

The question is: How many of the 100 compartments are open after the 100th pass?

Now, please try to solve the riddle with R yourself… after that I will provide you with one possible solution!

You should have got the quadratic numbers 1, 4, 9,…, 81, 100 – did you? If yes, well done!

To get the correct result we will do two things simultaneously: run through all the passes one after the other (with a `for`

loop) and, as a bonus, create an image for all the runs with the open doors in green and the closed doors in red (with the `image`

function):

ndoors <- 100 img <- matrix(nrow = ndoors, ncol = ndoors) which.door <- function (n, nd = ndoors) { seq(n, nd, n) } img_t <- function(m) { image(t(m)[ , nrow(m):1], col = c("red", "green"), xaxt = "n", yaxt = "n", xlab = "doors", ylab = "passes") axis(1, at = seq(0, 1, length.out = 11), labels = c(1, seq(10, 100, 10))) axis(2, at = seq(0, 1, length.out = 11), labels = c(seq(100, 10, -10), 1)) } pass <- rep(TRUE , ndoors) # TRUE = door open img[1, ] <- pass for (i in 2:ndoors) { pass[which.door(i)] <- !pass[which.door(i)] img[i, ] <- pass } which(pass) ## [1] 1 4 9 16 25 36 49 64 81 100 sum(pass) ## [1] 10 img_t(img)

Interesting how simple actions can create intricate patterns!

That was fun, wasn’t it! And I hope you learned something along the way… stay tuned!

]]>More and more companies use chatbots for engaging with their customers. Often the underlying technology is not too sophisticated, yet many people are stunned at how human-like those bots can appear. The earliest example of this was an early

Eliza was supposed to simulate a psychotherapist and was mainly created as a method to show the superficiality of communication between man and machine. Weizenbaum was surprised by the number of individuals who attributed human-like feelings to the computer program, including his own secretary!

If you want to build a simple Eliza-like chatbot yourself with R read on!

Have a look at the following conversation:

Eliza: Hello, I am Eliza

You: Hello Eliza

Eliza: How do you do. Please state your problem.

You: I am sad

Eliza: I am sorry to hear you are depressed

You: Perhaps you can help me

Eliza: You do not seem quite certain

You: Well, you are only a computer

Eliza: Why do you mention computers?

You: Sorry

Eliza: What feelings do you have when you apologize

You: Are you a computer?

Eliza: Do computers worry you?

You: Or are you human?

Eliza: Why are you interested in whether I am human or not?

You: It is not the same

Eliza: What other connections do you see?

You: I am glad I can talk to you

Eliza: What makes you happy just now?

You: That somebody listens to me

Eliza: Can you be more specific?

You: Everybody seems so busy nowadays

Eliza: You are being a bit negative.

You: That was not always the case

Eliza: When?

You: Back in the days when I was a kid and with my mother

Eliza: Tell me more about your family

You: My father was always working

Eliza: What else comes to mind when you think of your father?

You: I remember disputes

Eliza: Does thinking of disputes bring anything else to mind?

You: I was a shy kid

Eliza: Perhaps I already knew you were a shy kid.

You: You are experienced

Eliza: What makes you think I am experienced?

…

Quite impressive, isn’t it!

To build such a chatbot we need a *language model* that consists of *keyphrases* with *potential answers*. A simple model can be found here. We translate the data structure from Javascript into a `list`

where the names of the list members are our keyphrases and the content of each member comprises the potential answers:

model <- list( "hello" = c( "How do you do. Please state your problem." ), "computer" = c( "Do computers worry you?", "What do you think about machines?", "Why do you mention computers?", "What do you think machines have to do with your problem?" ), "name" = c( "I am not interested in names" ), "sorry" = c( "Please don't apologize", "Apologies are not necessary", "What feelings do you have when you apologize" ), "I remember" = c( "Do you often think of $?", "Does thinking of $ bring anything else to mind?", "What else do you remember?", "Why do you recall $ right now?", "What in the present situation reminds you of $?", "What is the connection between me and $?" ), "do you remember" = c( "Did you think I would forget $?", "Why do you think I should recall $ now?", "What about $?", "You mentioned $" ), "I want" = c( "What would it mean if you got $?", "Why do you want $?", "Suppose you got $ soon." ), "I dreamt" = c( "How do you feel about $ in reality?" ), "dream" = c( "What does this dream suggest to you?", "Do you dream often?", "What persons appear in your dreams?", "Don't you believe that dream has to do with your problem?" ), "my mother" = c( "Tell me more about your family" ), "my father" = c( "Your father?", "Does he influence you strongly?", "What else comes to mind when you think of your father?" ), "I am glad" = c( "How have I helped you to be $?", "What makes you happy just now?", "Can you explain why you are suddenly $?" ), "I am sad" = c( "I am sorry to hear you are depressed", "I'm sure it's not pleasant to be sad" ), "alike" = c( "In what way?", "What similarities are there?" ), "same" = c( "What other connections do you see?" ), "no" = c( "Why not?", "You are being a bit negative.", "Are you saying 'No' just to be negative?" ), "I was" = c( "Were you really?", "Perhaps I already knew you were $.", "Why do you tell me you were $ now?" ), "was I" = c( "What if you were $?", "Do you think you were $?", "What would it mean if you were $?" ), "I am" = c( "In what way are you $?", "Do you want to be $?" ), "am I" = c( "Do you believe you are $?", "Would you want to be $?", "You wish I would tell you you are $?", "What would it mean if you were $?" ), "are you" = c( "Why are you interested in whether I am $ or not?", "Would you prefer if I weren't $?", "Perhaps I am $ in your fantasies" ), "you are" = c( "What makes you think I am $?" ), "because" = c( "Is that the real reason?", "What other reasons might there be?", "Does that reason seem to explain anything else?" ), "were you" = c( "Perhaps I was $?", "What do you think?", "What if I had been $?" ), "I can't" = c( "Maybe you could $ now", "What if you could $?" ), "I feel" = c( "Do you often feel $?" ), "I felt" = c( "What other feelings do you have?" ), "why don't you" = c( "Should you $ yourself?", "Do you believe I don't $?", "Perhaps I will $ in good time" ), "yes" = c( "You seem quite positive", "You are sure?", "I understand" ), "somebody" = c( "Can you be more specific?" ), "everybody" = c( "Surely not everyone", "Can you think of anyone in particular?", "Who, for example?", "You are thinking of a special person" ), "always" = c( "Can you think of a specific example?", "When?", "What incident are you thinking of?", "Really--always?" ), "what" = c( "Why do you ask?", "Does that question interest you?", "What is it you really want to know?", "What do you think?", "What comes to your mind when you ask that?" ), "perhaps" = c( "You do not seem quite certain" ), "are" = c( "Did you think they might not be $?", "Possibly they are $" ) )

Additionally, we include some *default answers* in case no keyphrase is found:

default_model <- c( "Very interesting", "I am not sure I understand you fully", "What does that suggest to you?", "Please continue", "Go on", "Do you feel strongly about discussing such things?" )

The main code for the chatbot is quite short. The *pattern matching* takes place via *regular expressions* (with the `grep`

function). If no match is found a default answer is chosen randomly. If we got a match one of the potential answers is also chosen randomly. In some cases, those answers contain a `$`

sign as a placeholder. In this case, the last part of the input text is being extracted (with the `substr`

and `regexec`

function) and put into the answer at this point (with the `sub`

function):

Eliza <- function(input) { # match keywords from model pos <- which(lapply(paste0("(.*)?", names(model), "(.*)?"), grep, x = input, ignore.case = TRUE) == 1) output <- unlist(model[pos]) if (length(pos) == 0) { # choose default answer randomly if no keyword is found output <- sample(default_model, 1) } else { # choose applicable answer randomly pos <- ifelse(length (pos) > 1, sample(pos, 1), pos) output <- sample(output, 1) names(output) <- NULL # customize answer tmp <- regexec(names(model)[pos], input, ignore.case = TRUE)[[1]] end_phrase <- substr(input, start = attr(tmp, "match.length") + as.numeric(tmp) + 1, stop = nchar(input)) end_phrase <- trimws(end_phrase, which = "right", whitespace = "[?!.]") output <- sub("\\$", end_phrase, output) } output }

The user interaction is realized by a simple `while`

-loop asking for input (via the `readline`

function) until the user types “quit”:

input <- "" cat("Eliza: Hello, I am Eliza!\n") while (TRUE) { input <- readline("You: ") if (input == "quit") break cat("Eliza:", Eliza(input)) }

You can now start talking to your chatbot! You should also try to modify and extend the language model to make the conversations more sophisticated.

Have fun with your new friend and please share your thoughts and experiences in the comments below!

]]>How lucrative stocks are in the long run is not only dependent on the length of the investment period but even more on the actual date the investment starts and ends!

*Return Triangle Plots* are a great way to visualize this phenomenon. If you want to learn more about them and how to create them with R read on!

If you had invested in the Standard & Poors 500 index beginning of 2000 you would have had to wait 14 years until you were in the plus! The reason was, of course, the so-called dot-com bubble which was at its peak then and crashed soon afterwards. On the other hand, if you had invested in the same index beginning of 2003 you would have never had any loss below your initial investment and would have a return of more than 300% by now!

Return triangle plots are a great way to get to grips with this. The following function returns a return triangle for any ticker symbol (`Symbol`

) for any start (`from`

) and end year (`to`

). For retrieving the stock or index data we use the wonderful `quantmod`

package (on CRAN):

library(quantmod) ## Loading required package: xts ## Loading required package: zoo ## ## Attaching package: 'zoo' ## The following objects are masked from 'package:base': ## ## as.Date, as.Date.numeric ## Loading required package: TTR ## Registered S3 method overwritten by 'quantmod': ## method from ## as.zoo.data.frame zoo ## Version 0.4-0 included new data defaults. See ?getSymbols. return_triangle <- function(Symbol = "^GSPC", from = 2000, to = 2020) { symbol <- getSymbols(Symbol, from = paste0(from, "-01-01"), to = paste0(to, "-12-31"), auto.assign = FALSE) symbol_y <- coredata(to.yearly(symbol)[ , c(1, 4)]) from_to <- seq(from, to) M <- matrix(NA, nrow = length(from_to), ncol = length(from_to)) rownames(M) <- colnames(M) <- from_to for (buy in seq_along(from_to)) { for (sell in seq(buy, length(from_to))) { M[buy, sell] <- (symbol_y[sell, 2] - symbol_y[buy, 1]) / symbol_y[buy, 1] } } round(100 * M, 1) } rt <- return_triangle(from = 2009, to = 2020) ## 'getSymbols' currently uses auto.assign=TRUE by default, but will ## use auto.assign=FALSE in 0.5-0. You will still be able to use ## 'loadSymbols' to automatically load data. getOption("getSymbols.env") ## and getOption("getSymbols.auto.assign") will still be checked for ## alternate defaults. ## ## This message is shown once per session and may be disabled by setting ## options("getSymbols.warning4.0"=FALSE). See ?getSymbols for details. print(rt, na.print = "") ## 2009 2010 2011 2012 2013 2014 2015 2016 2017 2018 2019 2020 ## 2009 23.5 39.3 39.3 57.9 104.7 128.0 126.4 147.9 196.1 177.6 257.8 313.3 ## 2010 12.6 12.6 27.7 65.5 84.4 83.1 100.5 139.5 124.5 189.4 234.2 ## 2011 0.0 13.4 47.0 63.7 62.5 78.0 112.6 99.3 156.9 196.8 ## 2012 13.3 46.8 63.6 62.4 77.8 112.4 99.1 156.6 196.5 ## 2013 29.6 44.4 43.3 57.0 87.5 75.8 126.5 161.7 ## 2014 11.5 10.7 21.3 44.8 35.8 75.0 102.2 ## 2015 -0.7 8.7 29.9 21.8 56.9 81.3 ## 2016 9.8 31.2 23.0 58.5 83.1 ## 2017 18.7 11.3 43.5 65.8 ## 2018 -6.6 20.4 39.1 ## 2019 30.4 50.7 ## 2020 15.0

The rows represent the buy dates (beginning of the respective year), the columns the sell dates (end of the respective year). To create a return triangle plot out of that data we use the fantastic `plot.matrix`

package (on CRAN):

library(plot.matrix) rt <- return_triangle(from = 2000, to = 2020) bkp_par <- par(mar = c(5.1, 4.1, 4.1, 4.1)) # adapt margins plot(rt, digits = 1, text.cell = list(cex = 0.5), breaks = 15, col = colorRampPalette(c("red", "white", "green1", "green2", "green3", "green4", "darkgreen")), na.print = FALSE, border = NA, key = NULL, main = "S&P 500", xlab = "sell", ylab = "buy") par(bkp_par)

As it stands some care needs to be taken with setting the `breaks`

and `col`

arguments when creating your own triangle plots. It might help to remove `key = NULL`

so that you can see in the legend whether values below zero are in red and above in green. If you know some elegant method to set those values automatically please share it with us in the comments below. I will update the post with an honourable mention of you!

Back to the triangle plot itself: you can clearly see how whole periods form clusters of positive and negative returns… like a heat map with green hills and red valleys.

In the long run, all investments get into the green but with huge differences of sometimes several hundred percentage points! So even for long-term investors timing indeed is important but as every quant knows unfortunately very, very hard (if not outright impossible).

]]>The workhorse of Machine Learning is

Gradient Descent is a mathematical algorithm to optimize functions, i.e. finding their minima or maxima. In Machine Learning it is used to *minimize* the *cost function* of many learning algorithms, e.g. artificial neural networks a.k.a. deep learning. The cost function simply is the function that measures how good a set of predictions is compared to the actual values (e.g. in regression problems).

The gradient (technically the *negative* gradient) is the direction of steepest descent. Just imagine a skier standing on top of a hill: the direction which points into the direction of steepest descent is the gradient!

Mathematically the gradient “stores” all the partial derivative information of a multivariable function, basically the slopes with respect to the directions of all axes. So, the Gradient Descent-algorithm always moves in the direction of the gradient to reach the minimum of the function (NB: in some cases unfortunately only a *local minimum*!), like our skier always taking the steepest route to reach the valley as fast as possible!

The question is: why does a bundle of partial derivatives point in the direction of the steepest descent? I answered this question some time ago here: Math.SE: Why is gradient the direction of steepest ascent?

To give some intuition why the gradient (technically the negative gradient) has to point in the direction of steepest descent I created the following animation.

It shows all of the points that can be reached by a vector of a given length and two variables x and y that are multiplied by a constant and summed up to give a very simple linear function (which give very simple directional derivatives).

I then vary the constants relative to each other: when the constant of x goes up (down) the constant of y goes down (up). The red area equals the highest point which means that you have the steepest descent from there.

As can be seen, this point varies smoothly with the proportion of the constants which represent the derivatives in each direction!

Only when one constant equals zero do we have a corner solution, when both constants are the same the red area is exactly in the middle. There is no good reason why the red area (= steepest descent) should jump around between those points.

This means that the gradient will always point in the direction of the steepest descent (nb: which is of course not a proof but a hand-waving indication of its behaviour to give some intuition only!)

I created the animation with the `rgl`

package (on CRAN) and *ImageMagick* (see aso this post: Creating a Movie with Data from Outer Space in R).

The following fully documented code can be taken as a template to create plots and animations of 3D-functions with constraints (or inequalities). `f`

is defined as follows:

where is varied between and .

library(rgl) # create many x and y pairs as input of function x <- y <- seq(0, 10, 0.01) # define 3D-function with constraint f <- function(x, y) { ifelse(sqrt(x^2 + y^2) < 10, (3-n)*x + n*y, NA) } # for rainbow colouring the function nbcol <- 100 color <- rev(rainbow(nbcol, start = 0/6, end = 4/6)) zcol <- cut(z, nbcol) # loop for 3D-plots of function with n from 0 to 3 and back olddir <- setwd("anim") # change path accordingly nlim <- 3 step <- 0.1 niter <- c(seq(0, nlim, step), seq(nlim-step, step, -step)) for (i in 1:length(niter)) { n <- niter[i] z <- outer(x, y, f) zcol <- cut(z, nbcol) persp3d(x, y, z, col = color[zcol]) filename <- paste0("pic", ifelse((i-1) < 10, paste0("0", (i-1)), (i-1)), ".png") rgl.snapshot(filename, fmt = "png", top = TRUE) } # make animated gif with ImageMagick system("cmd.exe", input = "convert -delay 20 -loop 0 pic*.png gradient.gif") setwd(olddir)

I am always fascinated by how versatile R is!

]]>In this year’s end post I will give you a little programming challenge!

Everybody knows the Christmas song “The Twelve Days of Christmas”! Your task is to write an R script that creates the lyrics!

The lyrics are the following:

On the first day of Christmas

My true love gave to me:

A partridge in a pear tree.On the second day of Christmas

My true love gave to me:

Two turtle doves and

A partridge in a pear tree.On the third day of Christmas

My true love gave to me:

Three french hens

Two turtle doves and

A partridge in a pear tree.On the forth day of Christmas

My true love gave to me:

Four calling birds

Three french hens

Two turtle doves and

A partridge in a pear tree.…

On the Twelfth day of Christmas,

My true love gave to me:

Twelve drummers drumming

Eleven pipers piping

Ten lords a-leaping

Nine ladies dancing

Eight maids a-milking

Seven swans a-swimming

Six geese a-laying

Five golden rings

Four calling birds

Three french hens

Two turtle doves and

A partridge in a pear tree.

Your challenge is to write an R script to create the above lyrics. I provide the building blocks here as a starting point:

gifts <- c("A partridge in a pear tree.", "Two turtle doves and", "Three french hens", "Four calling birds", "Five golden rings", "Six geese a-laying", "Seven swans a-swimming", "Eight maids a-milking", "Nine ladies dancing", "Ten lords a-leaping", "Eleven pipers piping", "Twelve drummers drumming") days <- c("first", "second", "third", "fourth", "fifth", "sixth", "seventh", "eighth", "ninth", "tenth", "eleventh", "twelfth")

Hint: for the output you can use the `cat`

function, to concatenate (combine) strings you can use `paste`

and for a new line use `"\n"`

.

I will provide my solution below but you should give it a try… Have fun!

Here is my solution, which I also posted on Rosetta Code: The Twelve Days of Christmas:

for (i in 1:length(days)) { cat("On the", days[i], "day of Christmas\n") cat("My true love gave to me:\n") cat(paste(gifts[i:1], collapse = "\n"), "\n\n") }

I am always amazed at how elegantly one can code with R! If you have other solutions please don’t hesitate to share them with us in the comment section below.

I wish you all a Merry Christmas, Happy Holidays and A Happy New Year! (Hopefully, 2021 will be a better one than 2020!)

And above all: Please stay safe!

We will be taking our Christmas break and will be back on January 12, 2021!

]]>