31 |
--------------------------------------------------------------------------------
/man/logistic_solve1.Rd:
--------------------------------------------------------------------------------
1 | % Generated by roxygen2: do not edit by hand
2 | % Please edit documentation in R/RcppExports.R
3 | \name{logistic_solve1}
4 | \alias{logistic_solve1}
5 | \title{logistic_fit}
6 | \usage{
7 | logistic_solve1(x, y, w, initial_link, i, j, skip)
8 | }
9 | \arguments{
10 | \item{x}{NumericVector, expanatory variable.}
11 |
12 | \item{y}{NumericVector, 0/1 values to fit.}
13 |
14 | \item{w}{NumericVector, weights (required, positive).}
15 |
16 | \item{initial_link, }{initial link estimates (required, all zeroes is a good start).}
17 |
18 | \item{i}{integer, first index (inclusive).}
19 |
20 | \item{j}{integer, last index (inclusive).}
21 |
22 | \item{skip}{integer, index to skip (-1 to not skip).}
23 | }
24 | \value{
25 | vector of a and b.
26 | }
27 | \description{
28 | Calculate y ~ sigmoid(a + b x) using iteratively re-weighted least squares.
29 | Zero indexed.
30 | }
31 | \examples{
32 |
33 | set.seed(5)
34 | d <- data.frame(
35 | x = rnorm(10),
36 | y = sample(c(0,1), 10, replace = TRUE)
37 | )
38 | weights <- runif(nrow(d))
39 | m <- glm(y~x, data = d, family = binomial, weights = weights)
40 | coef(m)
41 | logistic_solve1(d$x, d$y, weights, rep(0.0, nrow(d)), 0, nrow(d)-1, -1)
42 |
43 | }
44 | \keyword{internal}
45 |
--------------------------------------------------------------------------------
/extras/check_reverse_dependencies.Rmd:
--------------------------------------------------------------------------------
1 | ---
2 | title: "check_reverse_dependencies"
3 | output: github_document
4 | ---
5 |
6 | ```{r, error=TRUE}
7 | library("prrd")
8 | td <- tempdir()
9 | package = "RcppDynProg"
10 | packageVersion(package)
11 | date()
12 |
13 | parallelCluster <- NULL
14 | # # parallel doesn't work due to https://github.com/r-lib/liteq/issues/22
15 | #ncores <- parallel::detectCores()
16 | #parallelCluster <- parallel::makeCluster(ncores)
17 |
18 | orig_dir <- getwd()
19 | print(orig_dir)
20 | setwd(td)
21 | print(td)
22 |
23 | options(repos = c(CRAN="https://cloud.r-project.org"))
24 | jobsdfe <- enqueueJobs(package=package, directory=td)
25 |
26 | mk_fn <- function(package, directory) {
27 | force(package)
28 | force(directory)
29 | function(i) {
30 | library("prrd")
31 | setwd(directory)
32 | Sys.sleep(1*i)
33 | dequeueJobs(package=package, directory=directory)
34 | }
35 | }
36 | f <- mk_fn(package=package, directory=td)
37 |
38 | if(!is.null(parallelCluster)) {
39 | parallel::parLapply(parallelCluster, seq_len(ncores), f)
40 | } else {
41 | f(0)
42 | }
43 |
44 | summariseQueue(package=package, directory=td)
45 |
46 | setwd(orig_dir)
47 | if(!is.null(parallelCluster)) {
48 | parallel::stopCluster(parallelCluster)
49 | }
50 |
51 | ```
52 |
53 |
--------------------------------------------------------------------------------
/R/xlin_fits_V.R:
--------------------------------------------------------------------------------
1 |
2 | #' xlin_fits_R
3 | #'
4 | #' Calculate out of sample linear fit predictions.
5 | #'
6 | #' @param x NumericVector, x-coords of values to group (length>=2).
7 | #' @param y NumericVector, values to group in order.
8 | #' @param w NumericVector, weights (positive).
9 | #' @return vector of predictions.
10 | #'
11 | #' @keywords internal
12 | #'
13 | #' @examples
14 | #'
15 | #' xlin_fits_V(c(1, 2, 3, 4), c(1, 2, 2, 1), c(1, 1, 1, 1))
16 | #'
17 | #' @export
18 | #'
19 | xlin_fits_V <- function(x, y, w) {
20 | n = length(y)
21 | # build fitting data
22 | regularization = 1.0e-5
23 | xx_0_0 = numeric(n) + sum(w*1)
24 | xx_1_0 = numeric(n) + sum(w*x)
25 | xx_0_1 = numeric(n) + sum(w*x)
26 | xx_1_1 = numeric(n) + sum(w*x*x)
27 | xy_0 = numeric(n) + sum(w*y)
28 | xy_1 = numeric(n) + sum(w*x*y)
29 | xx_1_0 = xx_1_0 + regularization
30 | xx_0_1 = xx_0_1 + regularization
31 | # pull out k'th observation
32 | xxk_0_0 = xx_0_0 - w*1
33 | xxk_1_0 = xx_1_0 - w*x
34 | xxk_0_1 = xx_0_1 - w*x
35 | xxk_1_1 = xx_1_1 - w*x*x
36 | xyk_0 = xy_0 - w*y
37 | xyk_1 = xy_1 - w*x*y
38 | # solve linear system
39 | det = xxk_0_0*xxk_1_1 - xxk_0_1*xxk_1_0
40 | c0 = (xxk_1_1*xyk_0 - xxk_0_1*xyk_1)/det
41 | c1 = (-xxk_1_0*xyk_0 + xxk_0_0*xyk_1)/det
42 | # form estimate
43 | y_est = c0 + c1*x
44 | return(y_est)
45 | }
46 |
47 |
--------------------------------------------------------------------------------
/extras/xlin_fits_py.py:
--------------------------------------------------------------------------------
1 | #!/usr/bin/env python3
2 | # -*- coding: utf-8 -*-
3 | """
4 | Created on Sun Dec 30 08:46:34 2018
5 |
6 | @author: johnmount
7 | """
8 |
9 | import numpy
10 |
11 | def xlin_fits_py(x, y, w):
12 | """return all out of sample fits of y~a*x+b weighted by w, all values numpy arrays"""
13 | n = len(y)
14 | # build fitting data
15 | regularization = 1.0e-5
16 | xx_0_0 = numpy.zeros(n) + numpy.sum(w*1)
17 | xx_1_0 = numpy.zeros(n) + numpy.sum(w*x)
18 | xx_0_1 = numpy.zeros(n) + numpy.sum(w*x)
19 | xx_1_1 = numpy.zeros(n) + numpy.sum(w*x*x)
20 | xy_0 = numpy.zeros(n) + numpy.sum(w*y)
21 | xy_1 = numpy.zeros(n) + numpy.sum(w*x*y)
22 | xx_1_0 = xx_1_0 + regularization
23 | xx_0_1 = xx_0_1 + regularization
24 | # pull out k'th observation
25 | xxk_0_0 = xx_0_0 - w*1
26 | xxk_1_0 = xx_1_0 - w*x
27 | xxk_0_1 = xx_0_1 - w*x
28 | xxk_1_1 = xx_1_1 - w*x*x
29 | xyk_0 = xy_0 - w*y
30 | xyk_1 = xy_1 - w*x*y
31 | # solve linear system
32 | det = xxk_0_0*xxk_1_1 - xxk_0_1*xxk_1_0
33 | c0 = (xxk_1_1*xyk_0 - xxk_0_1*xyk_1)/det
34 | c1 = (-xxk_1_0*xyk_0 + xxk_0_0*xyk_1)/det
35 | # form estimate
36 | y_est = c0 + c1*x
37 | return(y_est)
38 |
39 | # x = numpy.asarray([1 ,2, 3, 4])
40 | # y = numpy.asarray([1, 2, 2, 1])
41 | # w = numpy.asarray([1, 1, 1, 1])
42 | # xlin_fits_py(x, y, w)
43 | ## array([2.666715 , 1.28571541, 1.28571214, 2.66666833])
--------------------------------------------------------------------------------
/extras/Timings.Rmd:
--------------------------------------------------------------------------------
1 | ---
2 | title: "Timings"
3 | output: github_document
4 | ---
5 |
6 |
7 |
8 |
9 | ```{r}
10 | knitr::opts_chunk$set(fig.width=12, fig.height=8)
11 | library("RcppDynProg")
12 | library("WVPlots")
13 | library("microbenchmark")
14 | library("rqdatatable")
15 |
16 |
17 | set.seed(2018)
18 | n <- 500
19 | x <- matrix(runif(n*n), nrow=n, ncol=n)
20 |
21 | solve_interval_partition(x, n)
22 |
23 | solve_interval_partition_R(x, n)
24 |
25 | timings <- microbenchmark(
26 | solve_interval_partition(x, n),
27 | solve_interval_partition_R(x, n),
28 | times = 5L)
29 |
30 | print(timings)
31 |
32 | p <- data.frame(timings)
33 | p$seconds <- p$time/1e+9
34 | p$method <- as.factor(p$expr)
35 | p$method <- reorder(p$method, p$seconds)
36 |
37 | summary <- p %.>%
38 | project(.,
39 | mean_seconds = mean(seconds),
40 | groupby = "method")
41 | print(summary)
42 | ratio <- max(summary$mean_seconds)/min(summary$mean_seconds)
43 | print(ratio)
44 |
45 | WVPlots::ScatterBoxPlotH(p,
46 | "seconds", "method",
47 | "performance of same dynamic programming code in R and Rcpp (C++)")
48 | ```
49 |
50 |
51 |
52 |
53 | ---------------------
54 |
55 |
56 | Timings on a 2018 Dell XPS-13 laptop, 16 Gib RAM, LPDDR3, 2133 MT/s, Intel(R) Core(TM) i5-8250U CPU @ 1.60GHz (8 cores reported), idle, charged, and plugged into power supply. Ubuntu 18.04.1 LTS.
57 |
58 | ```{r}
59 | R.version.string
60 |
61 | R.version
62 |
63 | sessionInfo()
64 | ```
65 |
66 |
--------------------------------------------------------------------------------
/inst/tinytest/test_scoring.R:
--------------------------------------------------------------------------------
1 |
2 | test_scoring <- function() {
3 | set.seed(2018)
4 | g <- 50
5 | d <- data.frame(
6 | x = 1:(3*g)) # ordered in x
7 | d$y_ideal <- c(rep(0, g), rep(1, g), rep(-1, g))
8 | d$y_observed <- d$y_ideal + rnorm(length(d$y_ideal))
9 | d$w <- 1 + numeric(nrow(d))
10 |
11 | # expected loss of using the mean of other points to
12 | # estimate each point
13 | inflated_var <- function(x, penalty) {
14 | n <- length(x)
15 | if(n<=1) {
16 | return(100000)
17 | }
18 | meanx <- mean(x)
19 | (n/(n-1))^2*sum((x-meanx)^2) + penalty/sqrt(n)
20 | }
21 |
22 | c1 <- inflated_var(d$y_observed, 0)
23 | c2 <- const_cost(d$y_observed, d$w, 1, 0, length(d$y_observed-1)-1)
24 | expect_true(abs(c1-c2)<1.e-6)
25 |
26 | y_permuted <- d$y_ideal[sample.int(nrow(d), nrow(d), replace = FALSE)]
27 |
28 | create_cost_matrix <- function(ycol, penalty) {
29 | n <- length(ycol)
30 | x <- matrix(0, nrow=n, ncol=n)
31 | for(i in 1:n) {
32 | x[i,i] <- 100000 # big penalty
33 | if(i
59 |
60 | ``` r
61 | costs <- lin_costs_logistic(d$x, d$y_observed, w, 40, seq_len(nrow(d)))
62 | costs <- costs + 5
63 | soln <- solve_interval_partition(costs, 20)
64 | print(soln)
65 | ```
66 |
67 | ## [1] 1 59 255 315 424 471 601
68 |
69 | ``` r
70 | preds <- numeric(nrow(d))
71 | for(i in seqi(1, length(soln)-1)) {
72 | predsi <- logistic_fits(d$x, d$y_observed, w, soln[[i]]-1, soln[[i+1]]-2)
73 | preds[seqi(soln[[i]], soln[[i+1]]-1)] <- predsi
74 | }
75 | d$link <- pmin(5, pmax(-5, preds))
76 | d$group <- findInterval(seq_len(nrow(d)), soln)
77 |
78 |
79 | if(plot) {
80 | plt2 <- ggplot(data = d, aes(x = x)) +
81 | geom_line(aes(y = y_ideal), linetype=2) +
82 | geom_line(aes(y = link, group = group), linetype=3, color="blue") +
83 | geom_point(aes(y = y_plot, color = as.factor(d$y_observed)), alpha = 0.5) +
84 | ylab("y") +
85 | guides(color = FALSE) +
86 | ggtitle("raw data",
87 | subtitle = "dots: observed values, cuts/curve: recovered model")
88 | for(ci in soln) {
89 | if((ci>1)&&(ci`, then ``, etc.) that has more than one element. Defaults to 1 (for ``).
76 | getTopLevel: function($scope) {
77 | for (var i = 1; i <= 6; i++) {
78 | var $headings = this.findOrFilter($scope, 'h' + i);
79 | if ($headings.length > 1) {
80 | return i;
81 | }
82 | }
83 |
84 | return 1;
85 | },
86 |
87 | // returns the elements for the top level, and the next below it
88 | getHeadings: function($scope, topLevel) {
89 | var topSelector = 'h' + topLevel;
90 |
91 | var secondaryLevel = topLevel + 1;
92 | var secondarySelector = 'h' + secondaryLevel;
93 |
94 | return this.findOrFilter($scope, topSelector + ',' + secondarySelector);
95 | },
96 |
97 | getNavLevel: function(el) {
98 | return parseInt(el.tagName.charAt(1), 10);
99 | },
100 |
101 | populateNav: function($topContext, topLevel, $headings) {
102 | var $context = $topContext;
103 | var $prevNav;
104 |
105 | var helpers = this;
106 | $headings.each(function(i, el) {
107 | var $newNav = helpers.generateNavItem(el);
108 | var navLevel = helpers.getNavLevel(el);
109 |
110 | // determine the proper $context
111 | if (navLevel === topLevel) {
112 | // use top level
113 | $context = $topContext;
114 | } else if ($prevNav && $context === $topContext) {
115 | // create a new level of the tree and switch to it
116 | $context = helpers.createChildNavList($prevNav);
117 | } // else use the current $context
118 |
119 | $context.append($newNav);
120 |
121 | $prevNav = $newNav;
122 | });
123 | },
124 |
125 | parseOps: function(arg) {
126 | var opts;
127 | if (arg.jquery) {
128 | opts = {
129 | $nav: arg
130 | };
131 | } else {
132 | opts = arg;
133 | }
134 | opts.$scope = opts.$scope || $(document.body);
135 | return opts;
136 | }
137 | },
138 |
139 | // accepts a jQuery object, or an options object
140 | init: function(opts) {
141 | opts = this.helpers.parseOps(opts);
142 |
143 | // ensure that the data attribute is in place for styling
144 | opts.$nav.attr('data-toggle', 'toc');
145 |
146 | var $topContext = this.helpers.createChildNavList(opts.$nav);
147 | var topLevel = this.helpers.getTopLevel(opts.$scope);
148 | var $headings = this.helpers.getHeadings(opts.$scope, topLevel);
149 | this.helpers.populateNav($topContext, topLevel, $headings);
150 | }
151 | };
152 |
153 | $(function() {
154 | $('nav[data-toggle="toc"]').each(function(i, el) {
155 | var $nav = $(el);
156 | Toc.init($nav);
157 | });
158 | });
159 | })();
160 |
--------------------------------------------------------------------------------
/docs/articles/index.html:
--------------------------------------------------------------------------------
1 |
2 | Articles • RcppDynProg
6 |
7 |
8 |
9 |
53 |
54 |
55 |
56 |
57 |
58 |
59 | Articles
60 |
61 |
62 |
63 | All vignettes
64 |
65 |
66 | - RcppDynProg package
67 | -
68 |
- Segmentation
69 | -
70 |
- Linear Segmentation
71 | -
72 |
73 |
74 |
75 |
76 |
77 |
86 |
87 |
88 |
89 |
90 |
91 |
92 |
93 |
94 |
--------------------------------------------------------------------------------
/extras/Timings.md:
--------------------------------------------------------------------------------
1 | Timings
2 | ================
3 |
4 | ``` r
5 | knitr::opts_chunk$set(fig.width=12, fig.height=8)
6 | library("RcppDynProg")
7 | library("WVPlots")
8 | library("microbenchmark")
9 | library("rqdatatable")
10 | ```
11 |
12 | ## Loading required package: rquery
13 |
14 | ``` r
15 | set.seed(2018)
16 | n <- 500
17 | x <- matrix(runif(n*n), nrow=n, ncol=n)
18 |
19 | solve_interval_partition(x, n)
20 | ```
21 |
22 | ## [1] 1 109 230 267 501
23 |
24 | ``` r
25 | solve_interval_partition_R(x, n)
26 | ```
27 |
28 | ## [1] 1 109 230 267 501
29 |
30 | ``` r
31 | timings <- microbenchmark(
32 | solve_interval_partition(x, n),
33 | solve_interval_partition_R(x, n),
34 | times = 5L)
35 |
36 | print(timings)
37 | ```
38 |
39 | ## Unit: milliseconds
40 | ## expr min lq mean
41 | ## solve_interval_partition(x, n) 87.30949 87.56452 87.96436
42 | ## solve_interval_partition_R(x, n) 20932.52901 21096.78018 21188.00710
43 | ## median uq max neval
44 | ## 88.01139 88.22678 88.70962 5
45 | ## 21128.80190 21215.39725 21566.52718 5
46 |
47 | ``` r
48 | p <- data.frame(timings)
49 | p$seconds <- p$time/1e+9
50 | p$method <- as.factor(p$expr)
51 | p$method <- reorder(p$method, p$seconds)
52 |
53 | summary <- p %.>%
54 | project(.,
55 | mean_seconds = mean(seconds),
56 | groupby = "method")
57 | print(summary)
58 | ```
59 |
60 | ## method mean_seconds
61 | ## 1: solve_interval_partition_R(x, n) 21.18800710
62 | ## 2: solve_interval_partition(x, n) 0.08796436
63 |
64 | ``` r
65 | ratio <- max(summary$mean_seconds)/min(summary$mean_seconds)
66 | print(ratio)
67 | ```
68 |
69 | ## [1] 240.8704
70 |
71 | ``` r
72 | WVPlots::ScatterBoxPlotH(p,
73 | "seconds", "method",
74 | "performance of same dynamic programming code in R and Rcpp (C++)")
75 | ```
76 |
77 | 
78 |
79 | ------------------------------------------------------------------------
80 |
81 | Timings on a 2018 Dell XPS-13 laptop, 16 Gib RAM, LPDDR3, 2133 MT/s, Intel(R) Core(TM) i5-8250U CPU @ 1.60GHz (8 cores reported), idle, charged, and plugged into power supply. Ubuntu 18.04.1 LTS.
82 |
83 | ``` r
84 | R.version.string
85 | ```
86 |
87 | ## [1] "R version 3.5.1 (2018-07-02)"
88 |
89 | ``` r
90 | R.version
91 | ```
92 |
93 | ## _
94 | ## platform x86_64-pc-linux-gnu
95 | ## arch x86_64
96 | ## os linux-gnu
97 | ## system x86_64, linux-gnu
98 | ## status
99 | ## major 3
100 | ## minor 5.1
101 | ## year 2018
102 | ## month 07
103 | ## day 02
104 | ## svn rev 74947
105 | ## language R
106 | ## version.string R version 3.5.1 (2018-07-02)
107 | ## nickname Feather Spray
108 |
109 | ``` r
110 | sessionInfo()
111 | ```
112 |
113 | ## R version 3.5.1 (2018-07-02)
114 | ## Platform: x86_64-pc-linux-gnu (64-bit)
115 | ## Running under: Ubuntu 18.04.1 LTS
116 | ##
117 | ## Matrix products: default
118 | ## BLAS: /usr/lib/x86_64-linux-gnu/blas/libblas.so.3.7.1
119 | ## LAPACK: /usr/lib/x86_64-linux-gnu/lapack/liblapack.so.3.7.1
120 | ##
121 | ## locale:
122 | ## [1] LC_CTYPE=en_US.UTF-8 LC_NUMERIC=C
123 | ## [3] LC_TIME=en_US.UTF-8 LC_COLLATE=en_US.UTF-8
124 | ## [5] LC_MONETARY=en_US.UTF-8 LC_MESSAGES=en_US.UTF-8
125 | ## [7] LC_PAPER=en_US.UTF-8 LC_NAME=C
126 | ## [9] LC_ADDRESS=C LC_TELEPHONE=C
127 | ## [11] LC_MEASUREMENT=en_US.UTF-8 LC_IDENTIFICATION=C
128 | ##
129 | ## attached base packages:
130 | ## [1] stats graphics grDevices utils datasets methods base
131 | ##
132 | ## other attached packages:
133 | ## [1] rqdatatable_1.1.2 rquery_1.2.1 microbenchmark_1.4-6
134 | ## [4] WVPlots_1.0.7 RcppDynProg_0.1.0
135 | ##
136 | ## loaded via a namespace (and not attached):
137 | ## [1] Rcpp_1.0.0 sigr_1.0.3 pillar_1.3.0
138 | ## [4] compiler_3.5.1 plyr_1.8.4 bindr_0.1.1
139 | ## [7] tools_3.5.1 digest_0.6.18 lattice_0.20-38
140 | ## [10] evaluate_0.12 tibble_1.4.2 gtable_0.2.0
141 | ## [13] nlme_3.1-137 mgcv_1.8-26 pkgconfig_2.0.2
142 | ## [16] rlang_0.3.0.1 Matrix_1.2-15 parallel_3.5.1
143 | ## [19] yaml_2.2.0 xfun_0.4 bindrcpp_0.2.2
144 | ## [22] gridExtra_2.3 withr_2.1.2 stringr_1.3.1
145 | ## [25] dplyr_0.7.8 knitr_1.21 grid_3.5.1
146 | ## [28] tidyselect_0.2.5 data.table_1.11.8 glue_1.3.0
147 | ## [31] R6_2.3.0 rmarkdown_1.11 wrapr_1.8.2
148 | ## [34] ggplot2_3.1.0 purrr_0.2.5 magrittr_1.5
149 | ## [37] scales_1.0.0 htmltools_0.3.6 assertthat_0.2.0
150 | ## [40] colorspace_1.3-2 labeling_0.3 stringi_1.2.4
151 | ## [43] lazyeval_0.2.1 munsell_0.5.0 crayon_1.3.4
152 |
--------------------------------------------------------------------------------
/docs/404.html:
--------------------------------------------------------------------------------
1 |
2 |
3 |
4 |
5 |
6 |
7 |
8 | Page not found (404) • RcppDynProg
9 |
10 |
11 |
12 |
13 |
14 |
15 |
19 |
20 |
21 |
22 |
23 |
24 |
76 |
77 |
78 |
79 |
80 |
81 |
82 |
83 | Page not found (404)
84 |
85 |
86 | Content not found. Please use links in the navbar.
87 |
88 |
89 |
90 |
94 |
95 |
96 |
97 |
98 |
99 |
110 |
111 |
112 |
113 |
114 |
115 |
116 |
117 |
118 |
119 |
--------------------------------------------------------------------------------
/extras/sp500/sp500_long.Rmd:
--------------------------------------------------------------------------------
1 | ---
2 | title: "sp500 long"
3 | output: github_document
4 | ---
5 |
6 | ```{r r1, fig.height = 6, fig.width = 8, fig.align = "center"}
7 | library("RcppDynProg")
8 | library("ggplot2")
9 |
10 | # Data from:
11 | # https://finance.yahoo.com/quote/%5EGSPC/history?period1=-630950400&period2=1546416000&interval=1d&filter=history&frequency=1d
12 | sp500 <- read.csv("^GSPC.csv")
13 | sp500$Date <- as.Date(sp500$Date)
14 | sp500$x <- as.numeric(sp500$Date)
15 | sp500$log_price <- log(sp500$Adj.Close)
16 |
17 |
18 | sp500recent <- sp500[sp500$Date >= as.Date('2000-01-01'), ]
19 |
20 |
21 | # find penalty
22 | sp500recent$permuted <- sp500recent$log_price[sample.int(nrow(sp500recent),
23 | nrow(sp500recent),
24 | replace = FALSE)]
25 | # look for a penalty that prefers 1 segment on permuted data
26 | lb <- 0
27 | ub <- 100
28 | while(TRUE) {
29 | soln <- solve_for_partition(sp500recent$x, sp500recent$permuted, penalty = ub, max_k = 3)
30 | if(nrow(soln)==2) {
31 | break
32 | }
33 | lb <- ub
34 | ub <- 10*ub
35 | }
36 | while(TRUE) {
37 | penalty <- ceiling((lb+ub)/2)
38 | if(penalty>=ub) {
39 | break
40 | }
41 | soln <- solve_for_partition(sp500recent$x, sp500recent$permuted, penalty = penalty, max_k = 3)
42 | if(nrow(soln)==2) {
43 | ub <- penalty
44 | } else {
45 | lb <- penalty
46 | }
47 | }
48 | print(penalty)
49 |
50 | soln <- solve_for_partition(sp500recent$x, sp500recent$log_price, penalty = penalty)
51 | sp500recent$estimate <- exp(approx(soln$x, soln$pred,
52 | xout = sp500recent$x,
53 | method = "linear", rule = 2)$y)
54 | sp500recent$group <- as.character(
55 | findInterval(sp500recent$x, soln[soln$what=="left", "x"]))
56 |
57 | ggplot(data = sp500recent, aes(x = Date)) +
58 | geom_line(aes(y=Adj.Close), color = "darkgray") +
59 | geom_line(aes(y=estimate, color = group)) +
60 | ggtitle("segment approximation of historic sp500recent data",
61 | subtitle = paste("per-segment penalty =", penalty)) +
62 | theme(legend.position = "none") +
63 | scale_color_brewer(palette = "Dark2") +
64 | scale_y_log10()
65 | ```
66 |
67 | ```{r r2, fig.height = 6, fig.width = 8, fig.align = "center"}
68 | penalty <- 1
69 |
70 | soln <- solve_for_partition(sp500recent$x, sp500recent$log_price, penalty = penalty)
71 | sp500recent$estimate <- exp(approx(soln$x, soln$pred,
72 | xout = sp500recent$x,
73 | method = "linear", rule = 2)$y)
74 | sp500recent$group <- as.character(
75 | findInterval(sp500recent$x, soln[soln$what=="left", "x"]))
76 |
77 | ggplot(data = sp500recent, aes(x = Date)) +
78 | geom_line(aes(y=Adj.Close), color = "darkgray") +
79 | geom_line(aes(y=estimate, color = group)) +
80 | ggtitle("segment approximation of historic sp500 data",
81 | subtitle = paste("per-segment penalty =", penalty)) +
82 | theme(legend.position = "none") +
83 | scale_color_brewer(palette = "Dark2") +
84 | scale_y_log10()
85 | ```
86 |
87 | ```{r r3, fig.height = 6, fig.width = 8, fig.align = "center"}
88 | penalty <- 5
89 |
90 | soln <- solve_for_partition(sp500$x, sp500$log_price, penalty = penalty)
91 | sp500$estimate <- exp(approx(soln$x, soln$pred,
92 | xout = sp500$x,
93 | method = "linear", rule = 2)$y)
94 |
95 | sp500$group <- as.character(
96 | findInterval(sp500$x, soln[soln$what=="left", "x"]))
97 |
98 | ggplot(data = sp500, aes(x = Date)) +
99 | geom_line(aes(y=Adj.Close), color = "darkgray") +
100 | geom_line(aes(y=estimate, group = group), color = "darkgreen") +
101 | ggtitle("segment approximation of historic sp500 data",
102 | subtitle = paste("per-segment penalty =", penalty)) +
103 | theme(legend.position = "none") +
104 | scale_color_manual(values = colors) +
105 | scale_y_log10()
106 | ```
107 |
108 | Naive gaps (TODO: need to find breakpoints that are good for the no-gap solution).
109 |
110 | ```{r r4, fig.height = 6, fig.width = 8, fig.align = "center"}
111 | sl <- soln[soln$what=='left', ]
112 | fit <- vtreat:::encode_x_as_lambdas(
113 | sp500$x, min(sp500$x), max(sp500$x),
114 | sl$x)
115 | vars <- setdiff(colnames(fit), "intercept")
116 | fit$y <- sp500$log_price
117 | fmla <- wrapr::mk_formula("y", vars)
118 | model <- lm(fmla, data = fit)
119 | sp500$pred <- exp(predict(model, newdata = fit))
120 |
121 | ggplot(data = sp500, aes(x = Date)) +
122 | geom_line(aes(y=Adj.Close), color = "darkgray") +
123 | geom_line(aes(y=pred), color = "darkgreen") +
124 | ggtitle("segment approximation (no gaps) of historic sp500 data",
125 | subtitle = paste("per-segment penalty =", penalty)) +
126 | theme(legend.position = "none") +
127 | scale_color_brewer(palette = "Dark2") +
128 | scale_y_log10()
129 | ```
130 |
131 | Fit piecewise constant on delta series.
132 |
133 | ```{r r5, fig.height = 6, fig.width = 8, fig.align = "center"}
134 | penalty <- 0.01
135 |
136 | sp500$delta_log_price <- c(0, sp500$log_price[-1] - sp500$log_price[-nrow(sp500)])
137 |
138 | soln <- solve_for_partitionc(sp500$x, sp500$delta_log_price, penalty = penalty)
139 | sl <- soln[soln$what=='left', ]
140 | fit <- vtreat:::encode_x_as_lambdas(
141 | sp500$x, min(sp500$x), max(sp500$x),
142 | sl$x)
143 | vars <- setdiff(colnames(fit), "intercept")
144 | fit$y <- sp500$log_price
145 | fmla <- wrapr::mk_formula("y", vars)
146 | model <- lm(fmla, data = fit)
147 | sp500$pred <- exp(predict(model, newdata = fit))
148 |
149 | ggplot(data = sp500, aes(x = Date)) +
150 | geom_line(aes(y=Adj.Close), color = "darkgray") +
151 | geom_line(aes(y=pred), color = "darkgreen") +
152 | ggtitle("segment approximation (slope ests, no gaps) of historic sp500 data",
153 | subtitle = paste("per-segment penalty =", penalty)) +
154 | theme(legend.position = "none") +
155 | scale_color_brewer(palette = "Dark2") +
156 | scale_y_log10()
157 | ```
158 |
--------------------------------------------------------------------------------
/extras/time_python_xlin_fits.ipynb:
--------------------------------------------------------------------------------
1 | {
2 | "cells": [
3 | {
4 | "cell_type": "code",
5 | "execution_count": 1,
6 | "metadata": {},
7 | "outputs": [
8 | {
9 | "data": {
10 | "text/plain": [
11 | "array([2.666715 , 1.28571541, 1.28571214, 2.66666833])"
12 | ]
13 | },
14 | "execution_count": 1,
15 | "metadata": {},
16 | "output_type": "execute_result"
17 | }
18 | ],
19 | "source": [
20 | "\n",
21 | "import numpy\n",
22 | "import pandas\n",
23 | "import timeit\n",
24 | "\n",
25 | "from xlin_fits_py import *\n",
26 | "\n",
27 | "x = numpy.asarray([1 ,2, 3, 4])\n",
28 | "y = numpy.asarray([1, 2, 2, 1])\n",
29 | "w = numpy.asarray([1, 1, 1, 1])\n",
30 | "xlin_fits_py(x, y, w)\n",
31 | "\n",
32 | "\n"
33 | ]
34 | },
35 | {
36 | "cell_type": "code",
37 | "execution_count": 2,
38 | "metadata": {},
39 | "outputs": [
40 | {
41 | "data": {
42 | "text/html": [
43 | "\n",
44 | "\n",
57 | "\n",
58 | " \n",
59 | " \n",
60 | " x \n",
62 | " y_ideal \n",
63 | " y_observed \n",
64 | " \n",
65 | " \n",
66 | " \n",
67 | " \n",
68 | " 0 \n",
69 | " 0.05 \n",
70 | " 0.000225 \n",
71 | " 0.041055 \n",
72 | " \n",
73 | " \n",
74 | " 1 \n",
75 | " 0.10 \n",
76 | " 0.000900 \n",
77 | " 0.502473 \n",
78 | " \n",
79 | " \n",
80 | " 2 \n",
81 | " 0.15 \n",
82 | " 0.002025 \n",
83 | " -0.027719 \n",
84 | " \n",
85 | " \n",
86 | " 3 \n",
87 | " 0.20 \n",
88 | " 0.003600 \n",
89 | " -0.260338 \n",
90 | " \n",
91 | " \n",
92 | " 4 \n",
93 | " 0.25 \n",
94 | " 0.005625 \n",
95 | " 0.308052 \n",
96 | " \n",
97 | " \n",
98 | "
\n",
99 | ""
100 | ],
101 | "text/plain": [
102 | " x y_ideal y_observed\n",
103 | "0 0.05 0.000225 0.041055\n",
104 | "1 0.10 0.000900 0.502473\n",
105 | "2 0.15 0.002025 -0.027719\n",
106 | "3 0.20 0.003600 -0.260338\n",
107 | "4 0.25 0.005625 0.308052"
108 | ]
109 | },
110 | "execution_count": 2,
111 | "metadata": {},
112 | "output_type": "execute_result"
113 | }
114 | ],
115 | "source": [
116 | "d = pandas.read_csv('xlin_data.csv.gz', compression='gzip')\n",
117 | "d.head()\n"
118 | ]
119 | },
120 | {
121 | "cell_type": "code",
122 | "execution_count": 3,
123 | "metadata": {},
124 | "outputs": [],
125 | "source": [
126 | "x = numpy.asarray(d[\"x\"].tolist())\n",
127 | "y_observed = numpy.asarray(d[\"y_observed\"].tolist())\n",
128 | "w = numpy.zeros(len(x)) + 1"
129 | ]
130 | },
131 | {
132 | "cell_type": "code",
133 | "execution_count": 4,
134 | "metadata": {},
135 | "outputs": [],
136 | "source": [
137 | "s1 = xlin_fits_py(x, y_observed, w)"
138 | ]
139 | },
140 | {
141 | "cell_type": "code",
142 | "execution_count": 5,
143 | "metadata": {},
144 | "outputs": [
145 | {
146 | "name": "stdout",
147 | "output_type": "stream",
148 | "text": [
149 | "0.21375216569867916\n"
150 | ]
151 | }
152 | ],
153 | "source": [
154 | "\n",
155 | "reps = 10\n",
156 | "\n",
157 | "start = timeit.default_timer()\n",
158 | "for i in range(reps):\n",
159 | " xlin_fits_py(x, y_observed, w)\n",
160 | "end = timeit.default_timer()\n",
161 | "\n",
162 | "delta = end - start\n",
163 | "print(delta/reps)"
164 | ]
165 | },
166 | {
167 | "cell_type": "markdown",
168 | "metadata": {},
169 | "source": [
170 | "Timings on a 2018 Dell XPS-13 laptop, 16 Gib RAM, LPDDR3, 2133 MT/s, Intel(R) Core(TM) i5-8250U CPU @ 1.60GHz (8 cores reported), idle, charged, and plugged into power supply. Ubuntu 18.04.1 LTS.\n"
171 | ]
172 | },
173 | {
174 | "cell_type": "code",
175 | "execution_count": 6,
176 | "metadata": {},
177 | "outputs": [
178 | {
179 | "name": "stdout",
180 | "output_type": "stream",
181 | "text": [
182 | "sys.version_info(major=3, minor=7, micro=0, releaselevel='final', serial=0)\n",
183 | "1.15.1\n",
184 | "0.23.4\n"
185 | ]
186 | }
187 | ],
188 | "source": [
189 | "import sys\n",
190 | "\n",
191 | "print(sys.version_info)\n",
192 | "\n",
193 | "print(numpy.__version__)\n",
194 | "print(pandas.__version__)\n"
195 | ]
196 | },
197 | {
198 | "cell_type": "code",
199 | "execution_count": null,
200 | "metadata": {},
201 | "outputs": [],
202 | "source": []
203 | }
204 | ],
205 | "metadata": {
206 | "kernelspec": {
207 | "display_name": "Python 3",
208 | "language": "python",
209 | "name": "python3"
210 | },
211 | "language_info": {
212 | "codemirror_mode": {
213 | "name": "ipython",
214 | "version": 3
215 | },
216 | "file_extension": ".py",
217 | "mimetype": "text/x-python",
218 | "name": "python",
219 | "nbconvert_exporter": "python",
220 | "pygments_lexer": "ipython3",
221 | "version": "3.7.0"
222 | }
223 | },
224 | "nbformat": 4,
225 | "nbformat_minor": 2
226 | }
227 |
--------------------------------------------------------------------------------
/docs/articles/RcppDynProg.html:
--------------------------------------------------------------------------------
1 |
2 |
3 |
4 |
5 |
6 |
7 |
8 | RcppDynProg package • RcppDynProg
9 |
10 |
11 |
12 |
13 |
14 |
15 |
16 |
20 |
21 |
22 |
23 |
24 |
25 |
77 |
78 |
79 |
80 |
81 |
82 |
83 |
84 | RcppDynProg package
85 | John Mount
86 |
87 | 2023-08-19
88 |
89 | Source: vignettes/RcppDynProg.Rmd
90 | RcppDynProg.Rmd
91 |
92 |
93 |
94 |
95 |
96 | This content has moved to the package
97 | README.
98 |
99 |
100 |
103 |
104 |
105 |
106 |
107 |
108 |
119 |
120 |
121 |
122 |
123 |
124 |
125 |
126 |
127 |
128 |
--------------------------------------------------------------------------------
/extras/sp500/sp500_long.md:
--------------------------------------------------------------------------------
1 | sp500 long
2 | ================
3 |
4 | ``` r
5 | library("RcppDynProg")
6 | library("ggplot2")
7 |
8 | # Data from:
9 | # https://finance.yahoo.com/quote/%5EGSPC/history?period1=-630950400&period2=1546416000&interval=1d&filter=history&frequency=1d
10 | sp500 <- read.csv("^GSPC.csv")
11 | sp500$Date <- as.Date(sp500$Date)
12 | sp500$x <- as.numeric(sp500$Date)
13 | sp500$log_price <- log(sp500$Adj.Close)
14 |
15 |
16 | sp500recent <- sp500[sp500$Date >= as.Date('2000-01-01'), ]
17 |
18 |
19 | # find penalty
20 | sp500recent$permuted <- sp500recent$log_price[sample.int(nrow(sp500recent),
21 | nrow(sp500recent),
22 | replace = FALSE)]
23 | # look for a penalty that prefers 1 segment on permuted data
24 | lb <- 0
25 | ub <- 100
26 | while(TRUE) {
27 | soln <- solve_for_partition(sp500recent$x, sp500recent$permuted, penalty = ub, max_k = 3)
28 | if(nrow(soln)==2) {
29 | break
30 | }
31 | lb <- ub
32 | ub <- 10*ub
33 | }
34 | while(TRUE) {
35 | penalty <- ceiling((lb+ub)/2)
36 | if(penalty>=ub) {
37 | break
38 | }
39 | soln <- solve_for_partition(sp500recent$x, sp500recent$permuted, penalty = penalty, max_k = 3)
40 | if(nrow(soln)==2) {
41 | ub <- penalty
42 | } else {
43 | lb <- penalty
44 | }
45 | }
46 | print(penalty)
47 | ```
48 |
49 | ## [1] 10
50 |
51 | ``` r
52 | soln <- solve_for_partition(sp500recent$x, sp500recent$log_price, penalty = penalty)
53 | sp500recent$estimate <- exp(approx(soln$x, soln$pred,
54 | xout = sp500recent$x,
55 | method = "linear", rule = 2)$y)
56 | sp500recent$group <- as.character(
57 | findInterval(sp500recent$x, soln[soln$what=="left", "x"]))
58 |
59 | ggplot(data = sp500recent, aes(x = Date)) +
60 | geom_line(aes(y=Adj.Close), color = "darkgray") +
61 | geom_line(aes(y=estimate, color = group)) +
62 | ggtitle("segment approximation of historic sp500recent data",
63 | subtitle = paste("per-segment penalty =", penalty)) +
64 | theme(legend.position = "none") +
65 | scale_color_brewer(palette = "Dark2") +
66 | scale_y_log10()
67 | ```
68 |
69 | 
70 |
71 | ``` r
72 | penalty <- 1
73 |
74 | soln <- solve_for_partition(sp500recent$x, sp500recent$log_price, penalty = penalty)
75 | sp500recent$estimate <- exp(approx(soln$x, soln$pred,
76 | xout = sp500recent$x,
77 | method = "linear", rule = 2)$y)
78 | sp500recent$group <- as.character(
79 | findInterval(sp500recent$x, soln[soln$what=="left", "x"]))
80 |
81 | ggplot(data = sp500recent, aes(x = Date)) +
82 | geom_line(aes(y=Adj.Close), color = "darkgray") +
83 | geom_line(aes(y=estimate, color = group)) +
84 | ggtitle("segment approximation of historic sp500 data",
85 | subtitle = paste("per-segment penalty =", penalty)) +
86 | theme(legend.position = "none") +
87 | scale_color_brewer(palette = "Dark2") +
88 | scale_y_log10()
89 | ```
90 |
91 | 
92 |
93 | ``` r
94 | penalty <- 5
95 |
96 | soln <- solve_for_partition(sp500$x, sp500$log_price, penalty = penalty)
97 | sp500$estimate <- exp(approx(soln$x, soln$pred,
98 | xout = sp500$x,
99 | method = "linear", rule = 2)$y)
100 |
101 | sp500$group <- as.character(
102 | findInterval(sp500$x, soln[soln$what=="left", "x"]))
103 |
104 | ggplot(data = sp500, aes(x = Date)) +
105 | geom_line(aes(y=Adj.Close), color = "darkgray") +
106 | geom_line(aes(y=estimate, group = group), color = "darkgreen") +
107 | ggtitle("segment approximation of historic sp500 data",
108 | subtitle = paste("per-segment penalty =", penalty)) +
109 | theme(legend.position = "none") +
110 | scale_color_manual(values = colors) +
111 | scale_y_log10()
112 | ```
113 |
114 | 
115 |
116 | Naive gaps (TODO: need to find breakpoints that are good for the no-gap solution).
117 |
118 | ``` r
119 | sl <- soln[soln$what=='left', ]
120 | fit <- vtreat:::encode_x_as_lambdas(
121 | sp500$x, min(sp500$x), max(sp500$x),
122 | sl$x)
123 | vars <- setdiff(colnames(fit), "intercept")
124 | fit$y <- sp500$log_price
125 | fmla <- wrapr::mk_formula("y", vars)
126 | model <- lm(fmla, data = fit)
127 | sp500$pred <- exp(predict(model, newdata = fit))
128 |
129 | ggplot(data = sp500, aes(x = Date)) +
130 | geom_line(aes(y=Adj.Close), color = "darkgray") +
131 | geom_line(aes(y=pred), color = "darkgreen") +
132 | ggtitle("segment approximation (no gaps) of historic sp500 data",
133 | subtitle = paste("per-segment penalty =", penalty)) +
134 | theme(legend.position = "none") +
135 | scale_color_brewer(palette = "Dark2") +
136 | scale_y_log10()
137 | ```
138 |
139 | 
140 |
141 | Fit piecewise constant on delta series.
142 |
143 | ``` r
144 | penalty <- 0.01
145 |
146 | sp500$delta_log_price <- c(0, sp500$log_price[-1] - sp500$log_price[-nrow(sp500)])
147 |
148 | soln <- solve_for_partitionc(sp500$x, sp500$delta_log_price, penalty = penalty)
149 | sl <- soln[soln$what=='left', ]
150 | fit <- vtreat:::encode_x_as_lambdas(
151 | sp500$x, min(sp500$x), max(sp500$x),
152 | sl$x)
153 | vars <- setdiff(colnames(fit), "intercept")
154 | fit$y <- sp500$log_price
155 | fmla <- wrapr::mk_formula("y", vars)
156 | model <- lm(fmla, data = fit)
157 | sp500$pred <- exp(predict(model, newdata = fit))
158 |
159 | ggplot(data = sp500, aes(x = Date)) +
160 | geom_line(aes(y=Adj.Close), color = "darkgray") +
161 | geom_line(aes(y=pred), color = "darkgreen") +
162 | ggtitle("segment approximation (slope ests, no gaps) of historic sp500 data",
163 | subtitle = paste("per-segment penalty =", penalty)) +
164 | theme(legend.position = "none") +
165 | scale_color_brewer(palette = "Dark2") +
166 | scale_y_log10()
167 | ```
168 |
169 | 
170 |
--------------------------------------------------------------------------------
/docs/authors.html:
--------------------------------------------------------------------------------
1 |
2 | Authors and Citation • RcppDynProg
6 |
7 |
8 |
111 |
112 |
113 |
114 |
115 |
116 |
117 |
118 |
119 |
--------------------------------------------------------------------------------
/extras/sp500/sp500_example.Rmd:
--------------------------------------------------------------------------------
1 | ---
2 | title: "sp500 Example"
3 | output: pdf_document
4 | ---
5 |
6 | Another approach to segmentation is given by Koh, Kim, and Boyd's L1-Trend filter (refs [here](http://web.stanford.edu/~boyd/l1_tf/) and [here](http://web.stanford.edu/~boyd/papers/l1_trend_filter.html)). The approach is to, given a sequence $y$ of length $N$, use a global optimizer solve for a n-vector $x$ minimizing:
7 |
8 | \[ (1/2)||x-y||^2_2 + \lambda ||D x||_1 \]
9 |
10 | where $D$ is the second-order difference matrix that calculates $x_{k-1} - 2 x_{k} + x_{k+1}$ for all $k$. Or in other words find $x$ minimizing:
11 |
12 | \[ (1/2)||x-y||^2_2 + \lambda \sum_{k=2}^{N-1} |x_{k-1} - 2 x_{k} + x_{k+1}| \]
13 |
14 | They call the above Hodric-Prescott Filtering. It is *very* important to note that this sort of filtering is *not* appropriate for forecasting time-series (or *ex ante* work), as it is moving data from the future into the estimate in 2 ways:
15 |
16 | * $x_{k+1}$ is directly in the penalty term for $x_{k}$ (moving fit quality information known at time k+1 to time k).
17 | * It is using a global optimization to find all $x$ simultaneously, meaning choices of later $x$s can affect earlier choices.
18 |
19 | However, this sort of can be used to look at *ex post* (after the fact) changes in behavior.
20 |
21 | Richard Bellman wrote about a related smoothing filter in *Dynamic Programming*, Princeton 1958, Ch 1, section 7, minimizing:
22 |
23 | \[ \sum_{k=1}^{N} g_k(x_{k} - r_{k}) + \sum_{k=2}^{N} h_k(x_{k} - x_{k-1}) \]
24 |
25 | (here we are solving for $x$, given $r$ and the $g_k()$ and $h_k()$ are sequences of arbitrary penalty functions.
26 |
27 | Koh, Kim, and Boyd supplied [implementations of the method in both Matlab and C](http://web.stanford.edu/~boyd/l1_tf/), and Hadley Wickham provided a wrapper to make the `C` code available to [`R`](https://www.r-project.org) users. Dirk Eddelbuettel worked on an [`Rcpp` adaption of the methodology](https://github.com/eddelbuettel/rcppl1tf).
28 |
29 | The idea is: one can take series data (such as historic S&P 500 prices) and, by picking a smoothing $\lambda$ produce a graph such as the following:
30 |
31 | 
32 |
33 |
34 | [`RcppDynProg`](https://github.com/WinVector/RcppDynProg) uses a different, but related methodology. The user can specify any per-interval penalty, meaning fit quality does not have to be per-point additive. The default metric is the quality of a linear fit on the segment (discussed [here](https://winvector.github.io/RcppDynProg/articles/RcppDynProg.html)). Then by specifying a bound on the number of segments or a per-segment penalty (to discourage many small segments) a piecewise linear approximation is built up using a global dynamic program optimizer. Again: the non-local nature of the segment quality scores (the default score depends on all points in the segment, not just previous points) plus the global optimization mean the segmentation is only available after all the data are known (so not suitable for forecasting a time series forward).
35 |
36 | That being said the results look like the following.
37 |
38 | ```{r r1, fig.height = 6, fig.width = 8, fig.align = "center"}
39 | library("RcppDynProg")
40 | library("ggplot2")
41 |
42 | # Data from: https://github.com/eddelbuettel/l1tf/blob/master/data-raw/sp500.csv
43 | sp500 <- read.csv("sp500.csv")
44 | sp500$date <- as.Date(sp500$date)
45 |
46 | sp500$x <- as.numeric(sp500$date)
47 | sp500$permuted <- sp500$raw[sample.int(nrow(sp500), nrow(sp500), replace = FALSE)]
48 |
49 |
50 | soln <- solve_for_partition(sp500$x, sp500$raw, penalty = 250000)
51 | sp500$estimate <- approx(soln$x, soln$pred,
52 | xout = sp500$x,
53 | method = "linear", rule = 2)$y
54 | sp500$group <- as.character(
55 | findInterval(sp500$x, soln[soln$what=="left", "x"]))
56 |
57 | ggplot(data = sp500, aes(x = date)) +
58 | geom_line(aes(y=raw), color = "lightgray") +
59 | geom_line(aes(y=estimate, color = group)) +
60 | ggtitle("segment approximation of historic data",
61 | subtitle = "per-segment penalty = 250000") +
62 | theme(legend.position = "none") +
63 | scale_color_brewer(palette = "Dark2")
64 | ```
65 |
66 | Notice in our definition of piecewise we do not insist the pieces touch.
67 | A smoother that enforces that can be found [here](https://github.com/WinVector/vtreat/blob/master/R/segmented_variable.R) (demonstrated
68 | [here](https://github.com/WinVector/RcppDynProg/blob/master/extras/SegmentationL.md) as `PiecewiseV`).
69 |
70 | Or, instead of specifying a penalty, the user can specify a bound on the number of segments allowed.
71 |
72 |
73 | ```{r r2, fig.height = 6, fig.width = 8, fig.align = "center"}
74 | soln <- solve_for_partition(sp500$x, sp500$raw, max_k = 5, penalty = 0)
75 | sp500$estimate <- approx(soln$x, soln$pred,
76 | xout = sp500$x,
77 | method = "linear", rule = 2)$y
78 | sp500$group <- as.character(
79 | findInterval(sp500$x, soln[soln$what=="left", "x"]))
80 |
81 | ggplot(data = sp500, aes(x = date)) +
82 | geom_line(aes(y=raw), color = "lightgray") +
83 | geom_line(aes(y=estimate, color = group)) +
84 | ggtitle("5 segment approximation of historic data") +
85 | theme(legend.position = "none") +
86 | scale_color_brewer(palette = "Dark2")
87 | ```
88 |
89 |
90 | Or instead of specifying the penalty we can attempt to solve for
91 | a plausible value using a permutation test.
92 |
93 |
94 | ```{r r3, fig.height = 6, fig.width = 8, fig.align = "center"}
95 |
96 | # look for a penalty that prefers 1 segment on permuted data
97 | lb <- 0
98 | ub <- 100
99 | while(TRUE) {
100 | soln <- solve_for_partition(sp500$x, sp500$permuted, penalty = ub, max_k = 3)
101 | if(nrow(soln)==2) {
102 | break
103 | }
104 | lb <- ub
105 | ub <- 10*ub
106 | }
107 | while(TRUE) {
108 | penalty <- ceiling((lb+ub)/2)
109 | if(penalty>=ub) {
110 | break
111 | }
112 | soln <- solve_for_partition(sp500$x, sp500$permuted, penalty = penalty, max_k = 3)
113 | if(nrow(soln)==2) {
114 | ub <- penalty
115 | } else {
116 | lb <- penalty
117 | }
118 | }
119 | print(penalty)
120 |
121 | soln <- solve_for_partition(sp500$x, sp500$raw, penalty = penalty)
122 | sp500$estimate <- approx(soln$x, soln$pred,
123 | xout = sp500$x,
124 | method = "linear", rule = 2)$y
125 | sp500$group <- as.character(
126 | findInterval(sp500$x, soln[soln$what=="left", "x"]))
127 |
128 | ggplot(data = sp500, aes(x = date)) +
129 | geom_line(aes(y=raw), color = "lightgray") +
130 | geom_line(aes(y=estimate, color = group)) +
131 | ggtitle("segment approximation of historic data",
132 | subtitle = paste("per-segment penalty =", penalty)) +
133 | theme(legend.position = "none") +
134 | scale_color_brewer(palette = "Dark2")
135 |
136 | ```
137 |
--------------------------------------------------------------------------------
/extras/PseudoInverse.tex:
--------------------------------------------------------------------------------
1 |
2 | \documentclass{article}
3 |
4 | \usepackage{hyperref}
5 | \usepackage{amsmath}
6 | \usepackage{amssymb}
7 |
8 | \newtheorem{theorem}{Theorem}
9 |
10 | \begin{document}
11 |
12 | \title{The 2 by 2 Real Pseudo Inverse}
13 | \author{John Mount}
14 | \date{2019-01-07}
15 |
16 |
17 |
18 |
19 | \maketitle
20 |
21 |
22 | This is a brief note on the math behind the direct
23 | PRESS statistic calculation\footnote{\url{http://www.win-vector.com/blog/2014/09/estimating-generalization-error-with-the-press-statistic/}}
24 | found in the RcppDynProg package\footnote{\url{https://github.com/WinVector/RcppDynProg}}.
25 |
26 | The actual `C++` code\footnote{\url{https://github.com/WinVector/RcppDynProg/blob/master/src/xlin_fits.cpp}} is a bit ugly and intimidating. That is because we are using a verbose scalar notation to represent matrix concepts. In matrix notation we are solving a linear system by inverting a two by two matrix.\footnote{Yes, there are the usual admonitions that one should not invert a matrix to solve a linear system, but for systems this small they do not apply.} We are in turn inverting the two by two matrix by exploiting the following well know rule of how to invert a two by two matrix.
27 |
28 |
29 | If $a d - b c$ is not zero then:
30 |
31 | \[
32 | \begin{pmatrix} a & b \\ c & d \end{pmatrix}^{-1}
33 | =
34 | \frac{1}{a d - b c}
35 | \begin{pmatrix} d & -b \\ -c & a \end{pmatrix}
36 | \]
37 |
38 | Throughout $a$, $b$, $c$, and $d$ all real scalars.
39 |
40 | This can be re-written as the following general relation.
41 |
42 | \[
43 | \begin{pmatrix} a & b \\ c & d \end{pmatrix}
44 | \begin{pmatrix} d & -b \\ -c & a \end{pmatrix}
45 | =
46 | (a d - b c)
47 | \begin{pmatrix} 1 & 0 \\ 0 & 1 \end{pmatrix}
48 | \]
49 |
50 | The above can be directly checked just by applying the rules for multiplying matrices to the left two matrices. This has a particularly pleasant presentation if we recognize that $a d - b c$ is the determinant of the left matrix and use the traditional vertical bar determinant notation.
51 |
52 | \[
53 | \begin{pmatrix} a & b \\ c & d \end{pmatrix}
54 | \begin{pmatrix} d & -b \\ -c & a \end{pmatrix}
55 | =
56 | \begin{vmatrix} a & b \\ c & d \end{vmatrix}
57 | \begin{pmatrix} 1 & 0 \\ 0 & 1 \end{pmatrix}
58 | \]
59 |
60 |
61 |
62 | Now there is an issue of what to do when $a d - b c$ is zero. For our implementation we apply Tikhonov regularization\footnote{\url{https://en.wikipedia.org/wiki/Tikhonov_regularization}} which (barring the exact numeric coincidence of minus two times the expected value of the independent variable equaling our regularization constant) is going to be non-singular. For our actual application, we could simply switch degenerate situations to the out-of sample mean implementation\footnote{\url{https://github.com/WinVector/RcppDynProg/blob/master/src/const_costs.cpp}}.
63 |
64 | But, for fun, let's play with the math a bit.
65 |
66 | There is an additional lesser known algebraic relation for two by two matrices.
67 |
68 |
69 | \[
70 | \begin{pmatrix} a & b \\ c & d \end{pmatrix}
71 | \begin{pmatrix} a & c \\ b & d \end{pmatrix}
72 | \begin{pmatrix} a & b \\ c & d \end{pmatrix}
73 | =
74 | (a^2 + b^2 + c^2 + d^2)
75 | \begin{pmatrix} a & b \\ c & d \end{pmatrix}
76 | +
77 | (a d - b c)
78 | \begin{pmatrix} -d & c \\ b & -a \end{pmatrix}
79 | \]
80 |
81 | Or (using transpose, matrix squared Frobenius norm, and determinant notation):
82 |
83 | \begin{theorem}
84 | For any real 2 by 2 matrix
85 | $\begin{pmatrix} a & b \\ c & d \end{pmatrix}$ we have:
86 |
87 |
88 | \[
89 | \begin{pmatrix} a & b \\ c & d \end{pmatrix}
90 | \begin{pmatrix} a & b \\ c & d \end{pmatrix}^{\top}
91 | \begin{pmatrix} a & b \\ c & d \end{pmatrix}
92 | =
93 | \begin{Vmatrix} a & b \\ c & d \end{Vmatrix}_2^2
94 | \begin{pmatrix} a & b \\ c & d \end{pmatrix}
95 | +
96 | \begin{vmatrix} a & b \\ c & d \end{vmatrix}
97 | \begin{pmatrix} -d & c \\ b & -a \end{pmatrix}
98 | \].
99 | The superscript "top" denoting the transpose operation, the $||.||^2_2$ denoting sum of squares norm, and the single $|.|$ denoting determinant.
100 | \\ $\square$
101 | \label{thm:fmla}
102 | \end{theorem}
103 |
104 |
105 | This means, if $a d - b c$ is zero then:
106 |
107 |
108 | \[
109 | \begin{pmatrix} a & b \\ c & d \end{pmatrix}
110 | \begin{pmatrix} a & b \\ c & d \end{pmatrix}^{\top}
111 | \begin{pmatrix} a & b \\ c & d \end{pmatrix}
112 | =
113 | \begin{Vmatrix} a & b \\ c & d \end{Vmatrix}_2^2
114 | \begin{pmatrix} a & b \\ c & d \end{pmatrix}
115 | \]
116 |
117 |
118 | Once we [confirm the above relation\footnote{\url{https://github.com/WinVector/RcppDynProg/blob/master/extras/PseudoInverse.ipynb}} we can also confirm that if $a^2 + b^2 + c^2 + d^2$ is not zero, then the following matrix:
119 |
120 | \[
121 | \begin{pmatrix} a & b \\ c & d \end{pmatrix}^{+}
122 | =
123 | \frac{1}{a^2 + b^2 + c^2 + d^2}
124 | \begin{pmatrix} a & c \\ b & d \end{pmatrix}
125 | \]
126 |
127 | satisfies all of the conditions for being the Moore-Penrose inverse\footnote{\url{https://en.wikipedia.org/wiki/Moore–Penrose_inverse}} (or pseudo-inverse) of our original matrix. The superscript-plus denoting the Moore-Penrose inverse operation.
128 |
129 | Or in transpose notation:
130 |
131 | \[
132 | \begin{pmatrix} a & b \\ c & d \end{pmatrix}^{+}
133 | =
134 | \frac{1}{a^2 + b^2 + c^2 + d^2}
135 | \begin{pmatrix} a & b \\ c & d \end{pmatrix}^{\top}
136 | \]
137 |
138 | This is called the pseudo-inverse because it acts like an inverse, even for non-invertible matrices. For $A^{+}$ to be
139 | a More-Penrose inverse we must confirm it obeys the following relations:
140 |
141 | \begin{align*}
142 | A A^{+} A &= A \\
143 | A^{+} A A^{+} &= A^{+} \\
144 | (A A^{+})^{\top} &= A A^{+} \\
145 | (A^{+} A)^{\top} &= A^{+} A
146 | \end{align*}
147 |
148 | Theorem \ref{thm:fmla} lets us check the first relation, the other follow quickly as our $A^{+}$ is a simple scalar multiple of the transpose.\footnote{With the same scaling for both $A^{+}$ and $(A^{\top})^{+}$.}
149 |
150 | All of the above check relations would be true for a classic inverse. We can think of $A^{+}$ as almost canceling a single $A$ to the left or the $A$ to the right.
151 |
152 |
153 | \begin{theorem}
154 | For any real 2 by 2 matrix $\begin{pmatrix} a & b \\ c & d \end{pmatrix}$
155 |
156 | The Moore-Penrose inverse is:
157 |
158 |
159 | \begin{itemize}
160 |
161 |
162 | \item When $a d - b c$ is not zero:
163 |
164 | \[
165 | \frac{1}{a d - b c}
166 | \begin{pmatrix} d & -b \\ -c & a \end{pmatrix}
167 | \]
168 |
169 | \item When $a d - b c$ is zero and $a^2 + b^2 + c^2 + d^2$ is not zero:
170 |
171 | \[
172 | \frac{1}{a^2 + b^2 + c^2 + d^2}
173 | \begin{pmatrix} a & c \\ b & d \end{pmatrix}
174 | \]
175 |
176 | \item Otherwise:
177 |
178 | \[
179 | \begin{pmatrix} 0 & 0 \\ 0 & 0 \end{pmatrix}
180 | \]
181 | \end{itemize}
182 | .
183 | \\ $\square$
184 | \end{theorem}
185 |
186 | For general matrices the situation is much more complicated.
187 |
188 | The wealth of symmetries and relations is really kind of neat.
189 |
190 |
191 |
192 |
193 | \end{document}
194 |
--------------------------------------------------------------------------------
/docs/reference/RcppDynProg.html:
--------------------------------------------------------------------------------
1 |
2 |
3 |
4 |
5 |
6 |
7 |
8 |
9 | RcppDynProg — RcppDynProg • RcppDynProg
10 |
11 |
12 |
13 |
14 |
15 |
16 |
17 |
18 |
19 |
20 |
21 |
22 |
23 |
24 |
25 |
26 |
27 |
28 |
29 |
30 |
31 |
32 |
33 |
34 |
35 |
36 |
37 |
38 |
39 |
40 |
41 |
42 |
43 |
47 |
48 |
49 |
50 |
51 |
52 |
53 |
54 |
55 |
59 |
60 |
61 |
62 |
63 |
64 |
65 |
66 |
67 |
124 |
125 |
126 |
127 |
128 |
129 |
130 |
131 |
136 |
137 |
138 | Rcpp dynamic programming solutions for partitioning and machine learning problems.
139 | Includes out of sample fitting applications.
140 | Also supplies additional custom coders for the vtreat package.
141 | Please see https://github.com/WinVector/RcppDynProg for details.
142 |
143 |
144 |
145 |
146 | Author
147 |
148 | John Mount
149 |
150 |
151 |
156 |
157 |
158 |
159 |
169 |
170 |
171 |
172 |
173 |
174 |
175 |
176 |
177 |
178 |
--------------------------------------------------------------------------------
`).
76 | getTopLevel: function($scope) {
77 | for (var i = 1; i <= 6; i++) {
78 | var $headings = this.findOrFilter($scope, 'h' + i);
79 | if ($headings.length > 1) {
80 | return i;
81 | }
82 | }
83 |
84 | return 1;
85 | },
86 |
87 | // returns the elements for the top level, and the next below it
88 | getHeadings: function($scope, topLevel) {
89 | var topSelector = 'h' + topLevel;
90 |
91 | var secondaryLevel = topLevel + 1;
92 | var secondarySelector = 'h' + secondaryLevel;
93 |
94 | return this.findOrFilter($scope, topSelector + ',' + secondarySelector);
95 | },
96 |
97 | getNavLevel: function(el) {
98 | return parseInt(el.tagName.charAt(1), 10);
99 | },
100 |
101 | populateNav: function($topContext, topLevel, $headings) {
102 | var $context = $topContext;
103 | var $prevNav;
104 |
105 | var helpers = this;
106 | $headings.each(function(i, el) {
107 | var $newNav = helpers.generateNavItem(el);
108 | var navLevel = helpers.getNavLevel(el);
109 |
110 | // determine the proper $context
111 | if (navLevel === topLevel) {
112 | // use top level
113 | $context = $topContext;
114 | } else if ($prevNav && $context === $topContext) {
115 | // create a new level of the tree and switch to it
116 | $context = helpers.createChildNavList($prevNav);
117 | } // else use the current $context
118 |
119 | $context.append($newNav);
120 |
121 | $prevNav = $newNav;
122 | });
123 | },
124 |
125 | parseOps: function(arg) {
126 | var opts;
127 | if (arg.jquery) {
128 | opts = {
129 | $nav: arg
130 | };
131 | } else {
132 | opts = arg;
133 | }
134 | opts.$scope = opts.$scope || $(document.body);
135 | return opts;
136 | }
137 | },
138 |
139 | // accepts a jQuery object, or an options object
140 | init: function(opts) {
141 | opts = this.helpers.parseOps(opts);
142 |
143 | // ensure that the data attribute is in place for styling
144 | opts.$nav.attr('data-toggle', 'toc');
145 |
146 | var $topContext = this.helpers.createChildNavList(opts.$nav);
147 | var topLevel = this.helpers.getTopLevel(opts.$scope);
148 | var $headings = this.helpers.getHeadings(opts.$scope, topLevel);
149 | this.helpers.populateNav($topContext, topLevel, $headings);
150 | }
151 | };
152 |
153 | $(function() {
154 | $('nav[data-toggle="toc"]').each(function(i, el) {
155 | var $nav = $(el);
156 | Toc.init($nav);
157 | });
158 | });
159 | })();
160 |
--------------------------------------------------------------------------------
/docs/articles/index.html:
--------------------------------------------------------------------------------
1 |
2 | Articles • RcppDynProg
6 |
7 |
8 |
9 |
53 |
54 |
55 |
56 |
57 |
58 |
59 | Articles
60 |
61 |
62 |
63 | All vignettes
64 |
65 |
66 | - RcppDynProg package
67 | -
68 |
- Segmentation
69 | -
70 |
- Linear Segmentation
71 | -
72 |
73 |
74 |
75 |
76 |
77 |
86 |
87 |
88 |
89 |
90 |
91 |
92 |
93 |
94 |
--------------------------------------------------------------------------------
/extras/Timings.md:
--------------------------------------------------------------------------------
1 | Timings
2 | ================
3 |
4 | ``` r
5 | knitr::opts_chunk$set(fig.width=12, fig.height=8)
6 | library("RcppDynProg")
7 | library("WVPlots")
8 | library("microbenchmark")
9 | library("rqdatatable")
10 | ```
11 |
12 | ## Loading required package: rquery
13 |
14 | ``` r
15 | set.seed(2018)
16 | n <- 500
17 | x <- matrix(runif(n*n), nrow=n, ncol=n)
18 |
19 | solve_interval_partition(x, n)
20 | ```
21 |
22 | ## [1] 1 109 230 267 501
23 |
24 | ``` r
25 | solve_interval_partition_R(x, n)
26 | ```
27 |
28 | ## [1] 1 109 230 267 501
29 |
30 | ``` r
31 | timings <- microbenchmark(
32 | solve_interval_partition(x, n),
33 | solve_interval_partition_R(x, n),
34 | times = 5L)
35 |
36 | print(timings)
37 | ```
38 |
39 | ## Unit: milliseconds
40 | ## expr min lq mean
41 | ## solve_interval_partition(x, n) 87.30949 87.56452 87.96436
42 | ## solve_interval_partition_R(x, n) 20932.52901 21096.78018 21188.00710
43 | ## median uq max neval
44 | ## 88.01139 88.22678 88.70962 5
45 | ## 21128.80190 21215.39725 21566.52718 5
46 |
47 | ``` r
48 | p <- data.frame(timings)
49 | p$seconds <- p$time/1e+9
50 | p$method <- as.factor(p$expr)
51 | p$method <- reorder(p$method, p$seconds)
52 |
53 | summary <- p %.>%
54 | project(.,
55 | mean_seconds = mean(seconds),
56 | groupby = "method")
57 | print(summary)
58 | ```
59 |
60 | ## method mean_seconds
61 | ## 1: solve_interval_partition_R(x, n) 21.18800710
62 | ## 2: solve_interval_partition(x, n) 0.08796436
63 |
64 | ``` r
65 | ratio <- max(summary$mean_seconds)/min(summary$mean_seconds)
66 | print(ratio)
67 | ```
68 |
69 | ## [1] 240.8704
70 |
71 | ``` r
72 | WVPlots::ScatterBoxPlotH(p,
73 | "seconds", "method",
74 | "performance of same dynamic programming code in R and Rcpp (C++)")
75 | ```
76 |
77 | 
78 |
79 | ------------------------------------------------------------------------
80 |
81 | Timings on a 2018 Dell XPS-13 laptop, 16 Gib RAM, LPDDR3, 2133 MT/s, Intel(R) Core(TM) i5-8250U CPU @ 1.60GHz (8 cores reported), idle, charged, and plugged into power supply. Ubuntu 18.04.1 LTS.
82 |
83 | ``` r
84 | R.version.string
85 | ```
86 |
87 | ## [1] "R version 3.5.1 (2018-07-02)"
88 |
89 | ``` r
90 | R.version
91 | ```
92 |
93 | ## _
94 | ## platform x86_64-pc-linux-gnu
95 | ## arch x86_64
96 | ## os linux-gnu
97 | ## system x86_64, linux-gnu
98 | ## status
99 | ## major 3
100 | ## minor 5.1
101 | ## year 2018
102 | ## month 07
103 | ## day 02
104 | ## svn rev 74947
105 | ## language R
106 | ## version.string R version 3.5.1 (2018-07-02)
107 | ## nickname Feather Spray
108 |
109 | ``` r
110 | sessionInfo()
111 | ```
112 |
113 | ## R version 3.5.1 (2018-07-02)
114 | ## Platform: x86_64-pc-linux-gnu (64-bit)
115 | ## Running under: Ubuntu 18.04.1 LTS
116 | ##
117 | ## Matrix products: default
118 | ## BLAS: /usr/lib/x86_64-linux-gnu/blas/libblas.so.3.7.1
119 | ## LAPACK: /usr/lib/x86_64-linux-gnu/lapack/liblapack.so.3.7.1
120 | ##
121 | ## locale:
122 | ## [1] LC_CTYPE=en_US.UTF-8 LC_NUMERIC=C
123 | ## [3] LC_TIME=en_US.UTF-8 LC_COLLATE=en_US.UTF-8
124 | ## [5] LC_MONETARY=en_US.UTF-8 LC_MESSAGES=en_US.UTF-8
125 | ## [7] LC_PAPER=en_US.UTF-8 LC_NAME=C
126 | ## [9] LC_ADDRESS=C LC_TELEPHONE=C
127 | ## [11] LC_MEASUREMENT=en_US.UTF-8 LC_IDENTIFICATION=C
128 | ##
129 | ## attached base packages:
130 | ## [1] stats graphics grDevices utils datasets methods base
131 | ##
132 | ## other attached packages:
133 | ## [1] rqdatatable_1.1.2 rquery_1.2.1 microbenchmark_1.4-6
134 | ## [4] WVPlots_1.0.7 RcppDynProg_0.1.0
135 | ##
136 | ## loaded via a namespace (and not attached):
137 | ## [1] Rcpp_1.0.0 sigr_1.0.3 pillar_1.3.0
138 | ## [4] compiler_3.5.1 plyr_1.8.4 bindr_0.1.1
139 | ## [7] tools_3.5.1 digest_0.6.18 lattice_0.20-38
140 | ## [10] evaluate_0.12 tibble_1.4.2 gtable_0.2.0
141 | ## [13] nlme_3.1-137 mgcv_1.8-26 pkgconfig_2.0.2
142 | ## [16] rlang_0.3.0.1 Matrix_1.2-15 parallel_3.5.1
143 | ## [19] yaml_2.2.0 xfun_0.4 bindrcpp_0.2.2
144 | ## [22] gridExtra_2.3 withr_2.1.2 stringr_1.3.1
145 | ## [25] dplyr_0.7.8 knitr_1.21 grid_3.5.1
146 | ## [28] tidyselect_0.2.5 data.table_1.11.8 glue_1.3.0
147 | ## [31] R6_2.3.0 rmarkdown_1.11 wrapr_1.8.2
148 | ## [34] ggplot2_3.1.0 purrr_0.2.5 magrittr_1.5
149 | ## [37] scales_1.0.0 htmltools_0.3.6 assertthat_0.2.0
150 | ## [40] colorspace_1.3-2 labeling_0.3 stringi_1.2.4
151 | ## [43] lazyeval_0.2.1 munsell_0.5.0 crayon_1.3.4
152 |
--------------------------------------------------------------------------------
/docs/404.html:
--------------------------------------------------------------------------------
1 |
2 |
3 |
4 |
5 |
6 |
7 |
8 | Page not found (404) • RcppDynProg
9 |
10 |
11 |
12 |
13 |
14 |
15 |
19 |
20 |
21 |
22 |
23 |
24 |
76 |
77 |
78 |
79 |
80 |
81 |
82 |
83 | Page not found (404)
84 |
85 |
86 | Content not found. Please use links in the navbar.
87 |
88 |
89 |
90 |
94 |
95 |
96 |
97 |
98 |
99 |
110 |
111 |
112 |
113 |
114 |
115 |
116 |
117 |
118 |
119 |
--------------------------------------------------------------------------------
/extras/sp500/sp500_long.Rmd:
--------------------------------------------------------------------------------
1 | ---
2 | title: "sp500 long"
3 | output: github_document
4 | ---
5 |
6 | ```{r r1, fig.height = 6, fig.width = 8, fig.align = "center"}
7 | library("RcppDynProg")
8 | library("ggplot2")
9 |
10 | # Data from:
11 | # https://finance.yahoo.com/quote/%5EGSPC/history?period1=-630950400&period2=1546416000&interval=1d&filter=history&frequency=1d
12 | sp500 <- read.csv("^GSPC.csv")
13 | sp500$Date <- as.Date(sp500$Date)
14 | sp500$x <- as.numeric(sp500$Date)
15 | sp500$log_price <- log(sp500$Adj.Close)
16 |
17 |
18 | sp500recent <- sp500[sp500$Date >= as.Date('2000-01-01'), ]
19 |
20 |
21 | # find penalty
22 | sp500recent$permuted <- sp500recent$log_price[sample.int(nrow(sp500recent),
23 | nrow(sp500recent),
24 | replace = FALSE)]
25 | # look for a penalty that prefers 1 segment on permuted data
26 | lb <- 0
27 | ub <- 100
28 | while(TRUE) {
29 | soln <- solve_for_partition(sp500recent$x, sp500recent$permuted, penalty = ub, max_k = 3)
30 | if(nrow(soln)==2) {
31 | break
32 | }
33 | lb <- ub
34 | ub <- 10*ub
35 | }
36 | while(TRUE) {
37 | penalty <- ceiling((lb+ub)/2)
38 | if(penalty>=ub) {
39 | break
40 | }
41 | soln <- solve_for_partition(sp500recent$x, sp500recent$permuted, penalty = penalty, max_k = 3)
42 | if(nrow(soln)==2) {
43 | ub <- penalty
44 | } else {
45 | lb <- penalty
46 | }
47 | }
48 | print(penalty)
49 |
50 | soln <- solve_for_partition(sp500recent$x, sp500recent$log_price, penalty = penalty)
51 | sp500recent$estimate <- exp(approx(soln$x, soln$pred,
52 | xout = sp500recent$x,
53 | method = "linear", rule = 2)$y)
54 | sp500recent$group <- as.character(
55 | findInterval(sp500recent$x, soln[soln$what=="left", "x"]))
56 |
57 | ggplot(data = sp500recent, aes(x = Date)) +
58 | geom_line(aes(y=Adj.Close), color = "darkgray") +
59 | geom_line(aes(y=estimate, color = group)) +
60 | ggtitle("segment approximation of historic sp500recent data",
61 | subtitle = paste("per-segment penalty =", penalty)) +
62 | theme(legend.position = "none") +
63 | scale_color_brewer(palette = "Dark2") +
64 | scale_y_log10()
65 | ```
66 |
67 | ```{r r2, fig.height = 6, fig.width = 8, fig.align = "center"}
68 | penalty <- 1
69 |
70 | soln <- solve_for_partition(sp500recent$x, sp500recent$log_price, penalty = penalty)
71 | sp500recent$estimate <- exp(approx(soln$x, soln$pred,
72 | xout = sp500recent$x,
73 | method = "linear", rule = 2)$y)
74 | sp500recent$group <- as.character(
75 | findInterval(sp500recent$x, soln[soln$what=="left", "x"]))
76 |
77 | ggplot(data = sp500recent, aes(x = Date)) +
78 | geom_line(aes(y=Adj.Close), color = "darkgray") +
79 | geom_line(aes(y=estimate, color = group)) +
80 | ggtitle("segment approximation of historic sp500 data",
81 | subtitle = paste("per-segment penalty =", penalty)) +
82 | theme(legend.position = "none") +
83 | scale_color_brewer(palette = "Dark2") +
84 | scale_y_log10()
85 | ```
86 |
87 | ```{r r3, fig.height = 6, fig.width = 8, fig.align = "center"}
88 | penalty <- 5
89 |
90 | soln <- solve_for_partition(sp500$x, sp500$log_price, penalty = penalty)
91 | sp500$estimate <- exp(approx(soln$x, soln$pred,
92 | xout = sp500$x,
93 | method = "linear", rule = 2)$y)
94 |
95 | sp500$group <- as.character(
96 | findInterval(sp500$x, soln[soln$what=="left", "x"]))
97 |
98 | ggplot(data = sp500, aes(x = Date)) +
99 | geom_line(aes(y=Adj.Close), color = "darkgray") +
100 | geom_line(aes(y=estimate, group = group), color = "darkgreen") +
101 | ggtitle("segment approximation of historic sp500 data",
102 | subtitle = paste("per-segment penalty =", penalty)) +
103 | theme(legend.position = "none") +
104 | scale_color_manual(values = colors) +
105 | scale_y_log10()
106 | ```
107 |
108 | Naive gaps (TODO: need to find breakpoints that are good for the no-gap solution).
109 |
110 | ```{r r4, fig.height = 6, fig.width = 8, fig.align = "center"}
111 | sl <- soln[soln$what=='left', ]
112 | fit <- vtreat:::encode_x_as_lambdas(
113 | sp500$x, min(sp500$x), max(sp500$x),
114 | sl$x)
115 | vars <- setdiff(colnames(fit), "intercept")
116 | fit$y <- sp500$log_price
117 | fmla <- wrapr::mk_formula("y", vars)
118 | model <- lm(fmla, data = fit)
119 | sp500$pred <- exp(predict(model, newdata = fit))
120 |
121 | ggplot(data = sp500, aes(x = Date)) +
122 | geom_line(aes(y=Adj.Close), color = "darkgray") +
123 | geom_line(aes(y=pred), color = "darkgreen") +
124 | ggtitle("segment approximation (no gaps) of historic sp500 data",
125 | subtitle = paste("per-segment penalty =", penalty)) +
126 | theme(legend.position = "none") +
127 | scale_color_brewer(palette = "Dark2") +
128 | scale_y_log10()
129 | ```
130 |
131 | Fit piecewise constant on delta series.
132 |
133 | ```{r r5, fig.height = 6, fig.width = 8, fig.align = "center"}
134 | penalty <- 0.01
135 |
136 | sp500$delta_log_price <- c(0, sp500$log_price[-1] - sp500$log_price[-nrow(sp500)])
137 |
138 | soln <- solve_for_partitionc(sp500$x, sp500$delta_log_price, penalty = penalty)
139 | sl <- soln[soln$what=='left', ]
140 | fit <- vtreat:::encode_x_as_lambdas(
141 | sp500$x, min(sp500$x), max(sp500$x),
142 | sl$x)
143 | vars <- setdiff(colnames(fit), "intercept")
144 | fit$y <- sp500$log_price
145 | fmla <- wrapr::mk_formula("y", vars)
146 | model <- lm(fmla, data = fit)
147 | sp500$pred <- exp(predict(model, newdata = fit))
148 |
149 | ggplot(data = sp500, aes(x = Date)) +
150 | geom_line(aes(y=Adj.Close), color = "darkgray") +
151 | geom_line(aes(y=pred), color = "darkgreen") +
152 | ggtitle("segment approximation (slope ests, no gaps) of historic sp500 data",
153 | subtitle = paste("per-segment penalty =", penalty)) +
154 | theme(legend.position = "none") +
155 | scale_color_brewer(palette = "Dark2") +
156 | scale_y_log10()
157 | ```
158 |
--------------------------------------------------------------------------------
/extras/time_python_xlin_fits.ipynb:
--------------------------------------------------------------------------------
1 | {
2 | "cells": [
3 | {
4 | "cell_type": "code",
5 | "execution_count": 1,
6 | "metadata": {},
7 | "outputs": [
8 | {
9 | "data": {
10 | "text/plain": [
11 | "array([2.666715 , 1.28571541, 1.28571214, 2.66666833])"
12 | ]
13 | },
14 | "execution_count": 1,
15 | "metadata": {},
16 | "output_type": "execute_result"
17 | }
18 | ],
19 | "source": [
20 | "\n",
21 | "import numpy\n",
22 | "import pandas\n",
23 | "import timeit\n",
24 | "\n",
25 | "from xlin_fits_py import *\n",
26 | "\n",
27 | "x = numpy.asarray([1 ,2, 3, 4])\n",
28 | "y = numpy.asarray([1, 2, 2, 1])\n",
29 | "w = numpy.asarray([1, 1, 1, 1])\n",
30 | "xlin_fits_py(x, y, w)\n",
31 | "\n",
32 | "\n"
33 | ]
34 | },
35 | {
36 | "cell_type": "code",
37 | "execution_count": 2,
38 | "metadata": {},
39 | "outputs": [
40 | {
41 | "data": {
42 | "text/html": [
43 | "\n",
44 | "\n",
57 | "\n",
58 | " \n",
59 | " \n",
60 | " x \n",
62 | " y_ideal \n",
63 | " y_observed \n",
64 | " \n",
65 | " \n",
66 | " \n",
67 | " \n",
68 | " 0 \n",
69 | " 0.05 \n",
70 | " 0.000225 \n",
71 | " 0.041055 \n",
72 | " \n",
73 | " \n",
74 | " 1 \n",
75 | " 0.10 \n",
76 | " 0.000900 \n",
77 | " 0.502473 \n",
78 | " \n",
79 | " \n",
80 | " 2 \n",
81 | " 0.15 \n",
82 | " 0.002025 \n",
83 | " -0.027719 \n",
84 | " \n",
85 | " \n",
86 | " 3 \n",
87 | " 0.20 \n",
88 | " 0.003600 \n",
89 | " -0.260338 \n",
90 | " \n",
91 | " \n",
92 | " 4 \n",
93 | " 0.25 \n",
94 | " 0.005625 \n",
95 | " 0.308052 \n",
96 | " \n",
97 | " \n",
98 | "
\n",
99 | ""
100 | ],
101 | "text/plain": [
102 | " x y_ideal y_observed\n",
103 | "0 0.05 0.000225 0.041055\n",
104 | "1 0.10 0.000900 0.502473\n",
105 | "2 0.15 0.002025 -0.027719\n",
106 | "3 0.20 0.003600 -0.260338\n",
107 | "4 0.25 0.005625 0.308052"
108 | ]
109 | },
110 | "execution_count": 2,
111 | "metadata": {},
112 | "output_type": "execute_result"
113 | }
114 | ],
115 | "source": [
116 | "d = pandas.read_csv('xlin_data.csv.gz', compression='gzip')\n",
117 | "d.head()\n"
118 | ]
119 | },
120 | {
121 | "cell_type": "code",
122 | "execution_count": 3,
123 | "metadata": {},
124 | "outputs": [],
125 | "source": [
126 | "x = numpy.asarray(d[\"x\"].tolist())\n",
127 | "y_observed = numpy.asarray(d[\"y_observed\"].tolist())\n",
128 | "w = numpy.zeros(len(x)) + 1"
129 | ]
130 | },
131 | {
132 | "cell_type": "code",
133 | "execution_count": 4,
134 | "metadata": {},
135 | "outputs": [],
136 | "source": [
137 | "s1 = xlin_fits_py(x, y_observed, w)"
138 | ]
139 | },
140 | {
141 | "cell_type": "code",
142 | "execution_count": 5,
143 | "metadata": {},
144 | "outputs": [
145 | {
146 | "name": "stdout",
147 | "output_type": "stream",
148 | "text": [
149 | "0.21375216569867916\n"
150 | ]
151 | }
152 | ],
153 | "source": [
154 | "\n",
155 | "reps = 10\n",
156 | "\n",
157 | "start = timeit.default_timer()\n",
158 | "for i in range(reps):\n",
159 | " xlin_fits_py(x, y_observed, w)\n",
160 | "end = timeit.default_timer()\n",
161 | "\n",
162 | "delta = end - start\n",
163 | "print(delta/reps)"
164 | ]
165 | },
166 | {
167 | "cell_type": "markdown",
168 | "metadata": {},
169 | "source": [
170 | "Timings on a 2018 Dell XPS-13 laptop, 16 Gib RAM, LPDDR3, 2133 MT/s, Intel(R) Core(TM) i5-8250U CPU @ 1.60GHz (8 cores reported), idle, charged, and plugged into power supply. Ubuntu 18.04.1 LTS.\n"
171 | ]
172 | },
173 | {
174 | "cell_type": "code",
175 | "execution_count": 6,
176 | "metadata": {},
177 | "outputs": [
178 | {
179 | "name": "stdout",
180 | "output_type": "stream",
181 | "text": [
182 | "sys.version_info(major=3, minor=7, micro=0, releaselevel='final', serial=0)\n",
183 | "1.15.1\n",
184 | "0.23.4\n"
185 | ]
186 | }
187 | ],
188 | "source": [
189 | "import sys\n",
190 | "\n",
191 | "print(sys.version_info)\n",
192 | "\n",
193 | "print(numpy.__version__)\n",
194 | "print(pandas.__version__)\n"
195 | ]
196 | },
197 | {
198 | "cell_type": "code",
199 | "execution_count": null,
200 | "metadata": {},
201 | "outputs": [],
202 | "source": []
203 | }
204 | ],
205 | "metadata": {
206 | "kernelspec": {
207 | "display_name": "Python 3",
208 | "language": "python",
209 | "name": "python3"
210 | },
211 | "language_info": {
212 | "codemirror_mode": {
213 | "name": "ipython",
214 | "version": 3
215 | },
216 | "file_extension": ".py",
217 | "mimetype": "text/x-python",
218 | "name": "python",
219 | "nbconvert_exporter": "python",
220 | "pygments_lexer": "ipython3",
221 | "version": "3.7.0"
222 | }
223 | },
224 | "nbformat": 4,
225 | "nbformat_minor": 2
226 | }
227 |
--------------------------------------------------------------------------------
/docs/articles/RcppDynProg.html:
--------------------------------------------------------------------------------
1 |
2 |
3 |
4 |
5 |
6 |
7 |
8 | RcppDynProg package • RcppDynProg
9 |
10 |
11 |
12 |
13 |
14 |
15 |
16 |
20 |
21 |
22 |
23 |
24 |
25 |
77 |
78 |
79 |
80 |
81 |
82 |
83 |
84 | RcppDynProg package
85 | John Mount
86 |
87 | 2023-08-19
88 |
89 | Source: vignettes/RcppDynProg.Rmd
90 | RcppDynProg.Rmd
91 |
92 |
93 |
94 |
95 |
96 | This content has moved to the package
97 | README.
98 |
99 |
100 |
103 |
104 |
105 |
106 |
107 |
108 |
119 |
120 |
121 |
122 |
123 |
124 |
125 |
126 |
127 |
128 |
--------------------------------------------------------------------------------
/extras/sp500/sp500_long.md:
--------------------------------------------------------------------------------
1 | sp500 long
2 | ================
3 |
4 | ``` r
5 | library("RcppDynProg")
6 | library("ggplot2")
7 |
8 | # Data from:
9 | # https://finance.yahoo.com/quote/%5EGSPC/history?period1=-630950400&period2=1546416000&interval=1d&filter=history&frequency=1d
10 | sp500 <- read.csv("^GSPC.csv")
11 | sp500$Date <- as.Date(sp500$Date)
12 | sp500$x <- as.numeric(sp500$Date)
13 | sp500$log_price <- log(sp500$Adj.Close)
14 |
15 |
16 | sp500recent <- sp500[sp500$Date >= as.Date('2000-01-01'), ]
17 |
18 |
19 | # find penalty
20 | sp500recent$permuted <- sp500recent$log_price[sample.int(nrow(sp500recent),
21 | nrow(sp500recent),
22 | replace = FALSE)]
23 | # look for a penalty that prefers 1 segment on permuted data
24 | lb <- 0
25 | ub <- 100
26 | while(TRUE) {
27 | soln <- solve_for_partition(sp500recent$x, sp500recent$permuted, penalty = ub, max_k = 3)
28 | if(nrow(soln)==2) {
29 | break
30 | }
31 | lb <- ub
32 | ub <- 10*ub
33 | }
34 | while(TRUE) {
35 | penalty <- ceiling((lb+ub)/2)
36 | if(penalty>=ub) {
37 | break
38 | }
39 | soln <- solve_for_partition(sp500recent$x, sp500recent$permuted, penalty = penalty, max_k = 3)
40 | if(nrow(soln)==2) {
41 | ub <- penalty
42 | } else {
43 | lb <- penalty
44 | }
45 | }
46 | print(penalty)
47 | ```
48 |
49 | ## [1] 10
50 |
51 | ``` r
52 | soln <- solve_for_partition(sp500recent$x, sp500recent$log_price, penalty = penalty)
53 | sp500recent$estimate <- exp(approx(soln$x, soln$pred,
54 | xout = sp500recent$x,
55 | method = "linear", rule = 2)$y)
56 | sp500recent$group <- as.character(
57 | findInterval(sp500recent$x, soln[soln$what=="left", "x"]))
58 |
59 | ggplot(data = sp500recent, aes(x = Date)) +
60 | geom_line(aes(y=Adj.Close), color = "darkgray") +
61 | geom_line(aes(y=estimate, color = group)) +
62 | ggtitle("segment approximation of historic sp500recent data",
63 | subtitle = paste("per-segment penalty =", penalty)) +
64 | theme(legend.position = "none") +
65 | scale_color_brewer(palette = "Dark2") +
66 | scale_y_log10()
67 | ```
68 |
69 |
70 |
71 | ``` r
72 | penalty <- 1
73 |
74 | soln <- solve_for_partition(sp500recent$x, sp500recent$log_price, penalty = penalty)
75 | sp500recent$estimate <- exp(approx(soln$x, soln$pred,
76 | xout = sp500recent$x,
77 | method = "linear", rule = 2)$y)
78 | sp500recent$group <- as.character(
79 | findInterval(sp500recent$x, soln[soln$what=="left", "x"]))
80 |
81 | ggplot(data = sp500recent, aes(x = Date)) +
82 | geom_line(aes(y=Adj.Close), color = "darkgray") +
83 | geom_line(aes(y=estimate, color = group)) +
84 | ggtitle("segment approximation of historic sp500 data",
85 | subtitle = paste("per-segment penalty =", penalty)) +
86 | theme(legend.position = "none") +
87 | scale_color_brewer(palette = "Dark2") +
88 | scale_y_log10()
89 | ```
90 |
91 |
92 |
93 | ``` r
94 | penalty <- 5
95 |
96 | soln <- solve_for_partition(sp500$x, sp500$log_price, penalty = penalty)
97 | sp500$estimate <- exp(approx(soln$x, soln$pred,
98 | xout = sp500$x,
99 | method = "linear", rule = 2)$y)
100 |
101 | sp500$group <- as.character(
102 | findInterval(sp500$x, soln[soln$what=="left", "x"]))
103 |
104 | ggplot(data = sp500, aes(x = Date)) +
105 | geom_line(aes(y=Adj.Close), color = "darkgray") +
106 | geom_line(aes(y=estimate, group = group), color = "darkgreen") +
107 | ggtitle("segment approximation of historic sp500 data",
108 | subtitle = paste("per-segment penalty =", penalty)) +
109 | theme(legend.position = "none") +
110 | scale_color_manual(values = colors) +
111 | scale_y_log10()
112 | ```
113 |
114 |
115 |
116 | Naive gaps (TODO: need to find breakpoints that are good for the no-gap solution).
117 |
118 | ``` r
119 | sl <- soln[soln$what=='left', ]
120 | fit <- vtreat:::encode_x_as_lambdas(
121 | sp500$x, min(sp500$x), max(sp500$x),
122 | sl$x)
123 | vars <- setdiff(colnames(fit), "intercept")
124 | fit$y <- sp500$log_price
125 | fmla <- wrapr::mk_formula("y", vars)
126 | model <- lm(fmla, data = fit)
127 | sp500$pred <- exp(predict(model, newdata = fit))
128 |
129 | ggplot(data = sp500, aes(x = Date)) +
130 | geom_line(aes(y=Adj.Close), color = "darkgray") +
131 | geom_line(aes(y=pred), color = "darkgreen") +
132 | ggtitle("segment approximation (no gaps) of historic sp500 data",
133 | subtitle = paste("per-segment penalty =", penalty)) +
134 | theme(legend.position = "none") +
135 | scale_color_brewer(palette = "Dark2") +
136 | scale_y_log10()
137 | ```
138 |
139 |
140 |
141 | Fit piecewise constant on delta series.
142 |
143 | ``` r
144 | penalty <- 0.01
145 |
146 | sp500$delta_log_price <- c(0, sp500$log_price[-1] - sp500$log_price[-nrow(sp500)])
147 |
148 | soln <- solve_for_partitionc(sp500$x, sp500$delta_log_price, penalty = penalty)
149 | sl <- soln[soln$what=='left', ]
150 | fit <- vtreat:::encode_x_as_lambdas(
151 | sp500$x, min(sp500$x), max(sp500$x),
152 | sl$x)
153 | vars <- setdiff(colnames(fit), "intercept")
154 | fit$y <- sp500$log_price
155 | fmla <- wrapr::mk_formula("y", vars)
156 | model <- lm(fmla, data = fit)
157 | sp500$pred <- exp(predict(model, newdata = fit))
158 |
159 | ggplot(data = sp500, aes(x = Date)) +
160 | geom_line(aes(y=Adj.Close), color = "darkgray") +
161 | geom_line(aes(y=pred), color = "darkgreen") +
162 | ggtitle("segment approximation (slope ests, no gaps) of historic sp500 data",
163 | subtitle = paste("per-segment penalty =", penalty)) +
164 | theme(legend.position = "none") +
165 | scale_color_brewer(palette = "Dark2") +
166 | scale_y_log10()
167 | ```
168 |
169 |
170 |
--------------------------------------------------------------------------------
/docs/authors.html:
--------------------------------------------------------------------------------
1 |
2 | Authors and Citation • RcppDynProg
6 |
7 |
8 |
111 |
112 |
113 |
114 |
115 |
116 |
117 |
118 |
119 |
--------------------------------------------------------------------------------
/extras/sp500/sp500_example.Rmd:
--------------------------------------------------------------------------------
1 | ---
2 | title: "sp500 Example"
3 | output: pdf_document
4 | ---
5 |
6 | Another approach to segmentation is given by Koh, Kim, and Boyd's L1-Trend filter (refs [here](http://web.stanford.edu/~boyd/l1_tf/) and [here](http://web.stanford.edu/~boyd/papers/l1_trend_filter.html)). The approach is to, given a sequence $y$ of length $N$, use a global optimizer solve for a n-vector $x$ minimizing:
7 |
8 | \[ (1/2)||x-y||^2_2 + \lambda ||D x||_1 \]
9 |
10 | where $D$ is the second-order difference matrix that calculates $x_{k-1} - 2 x_{k} + x_{k+1}$ for all $k$. Or in other words find $x$ minimizing:
11 |
12 | \[ (1/2)||x-y||^2_2 + \lambda \sum_{k=2}^{N-1} |x_{k-1} - 2 x_{k} + x_{k+1}| \]
13 |
14 | They call the above Hodric-Prescott Filtering. It is *very* important to note that this sort of filtering is *not* appropriate for forecasting time-series (or *ex ante* work), as it is moving data from the future into the estimate in 2 ways:
15 |
16 | * $x_{k+1}$ is directly in the penalty term for $x_{k}$ (moving fit quality information known at time k+1 to time k).
17 | * It is using a global optimization to find all $x$ simultaneously, meaning choices of later $x$s can affect earlier choices.
18 |
19 | However, this sort of can be used to look at *ex post* (after the fact) changes in behavior.
20 |
21 | Richard Bellman wrote about a related smoothing filter in *Dynamic Programming*, Princeton 1958, Ch 1, section 7, minimizing:
22 |
23 | \[ \sum_{k=1}^{N} g_k(x_{k} - r_{k}) + \sum_{k=2}^{N} h_k(x_{k} - x_{k-1}) \]
24 |
25 | (here we are solving for $x$, given $r$ and the $g_k()$ and $h_k()$ are sequences of arbitrary penalty functions.
26 |
27 | Koh, Kim, and Boyd supplied [implementations of the method in both Matlab and C](http://web.stanford.edu/~boyd/l1_tf/), and Hadley Wickham provided a wrapper to make the `C` code available to [`R`](https://www.r-project.org) users. Dirk Eddelbuettel worked on an [`Rcpp` adaption of the methodology](https://github.com/eddelbuettel/rcppl1tf).
28 |
29 | The idea is: one can take series data (such as historic S&P 500 prices) and, by picking a smoothing $\lambda$ produce a graph such as the following:
30 |
31 | 
32 |
33 |
34 | [`RcppDynProg`](https://github.com/WinVector/RcppDynProg) uses a different, but related methodology. The user can specify any per-interval penalty, meaning fit quality does not have to be per-point additive. The default metric is the quality of a linear fit on the segment (discussed [here](https://winvector.github.io/RcppDynProg/articles/RcppDynProg.html)). Then by specifying a bound on the number of segments or a per-segment penalty (to discourage many small segments) a piecewise linear approximation is built up using a global dynamic program optimizer. Again: the non-local nature of the segment quality scores (the default score depends on all points in the segment, not just previous points) plus the global optimization mean the segmentation is only available after all the data are known (so not suitable for forecasting a time series forward).
35 |
36 | That being said the results look like the following.
37 |
38 | ```{r r1, fig.height = 6, fig.width = 8, fig.align = "center"}
39 | library("RcppDynProg")
40 | library("ggplot2")
41 |
42 | # Data from: https://github.com/eddelbuettel/l1tf/blob/master/data-raw/sp500.csv
43 | sp500 <- read.csv("sp500.csv")
44 | sp500$date <- as.Date(sp500$date)
45 |
46 | sp500$x <- as.numeric(sp500$date)
47 | sp500$permuted <- sp500$raw[sample.int(nrow(sp500), nrow(sp500), replace = FALSE)]
48 |
49 |
50 | soln <- solve_for_partition(sp500$x, sp500$raw, penalty = 250000)
51 | sp500$estimate <- approx(soln$x, soln$pred,
52 | xout = sp500$x,
53 | method = "linear", rule = 2)$y
54 | sp500$group <- as.character(
55 | findInterval(sp500$x, soln[soln$what=="left", "x"]))
56 |
57 | ggplot(data = sp500, aes(x = date)) +
58 | geom_line(aes(y=raw), color = "lightgray") +
59 | geom_line(aes(y=estimate, color = group)) +
60 | ggtitle("segment approximation of historic data",
61 | subtitle = "per-segment penalty = 250000") +
62 | theme(legend.position = "none") +
63 | scale_color_brewer(palette = "Dark2")
64 | ```
65 |
66 | Notice in our definition of piecewise we do not insist the pieces touch.
67 | A smoother that enforces that can be found [here](https://github.com/WinVector/vtreat/blob/master/R/segmented_variable.R) (demonstrated
68 | [here](https://github.com/WinVector/RcppDynProg/blob/master/extras/SegmentationL.md) as `PiecewiseV`).
69 |
70 | Or, instead of specifying a penalty, the user can specify a bound on the number of segments allowed.
71 |
72 |
73 | ```{r r2, fig.height = 6, fig.width = 8, fig.align = "center"}
74 | soln <- solve_for_partition(sp500$x, sp500$raw, max_k = 5, penalty = 0)
75 | sp500$estimate <- approx(soln$x, soln$pred,
76 | xout = sp500$x,
77 | method = "linear", rule = 2)$y
78 | sp500$group <- as.character(
79 | findInterval(sp500$x, soln[soln$what=="left", "x"]))
80 |
81 | ggplot(data = sp500, aes(x = date)) +
82 | geom_line(aes(y=raw), color = "lightgray") +
83 | geom_line(aes(y=estimate, color = group)) +
84 | ggtitle("5 segment approximation of historic data") +
85 | theme(legend.position = "none") +
86 | scale_color_brewer(palette = "Dark2")
87 | ```
88 |
89 |
90 | Or instead of specifying the penalty we can attempt to solve for
91 | a plausible value using a permutation test.
92 |
93 |
94 | ```{r r3, fig.height = 6, fig.width = 8, fig.align = "center"}
95 |
96 | # look for a penalty that prefers 1 segment on permuted data
97 | lb <- 0
98 | ub <- 100
99 | while(TRUE) {
100 | soln <- solve_for_partition(sp500$x, sp500$permuted, penalty = ub, max_k = 3)
101 | if(nrow(soln)==2) {
102 | break
103 | }
104 | lb <- ub
105 | ub <- 10*ub
106 | }
107 | while(TRUE) {
108 | penalty <- ceiling((lb+ub)/2)
109 | if(penalty>=ub) {
110 | break
111 | }
112 | soln <- solve_for_partition(sp500$x, sp500$permuted, penalty = penalty, max_k = 3)
113 | if(nrow(soln)==2) {
114 | ub <- penalty
115 | } else {
116 | lb <- penalty
117 | }
118 | }
119 | print(penalty)
120 |
121 | soln <- solve_for_partition(sp500$x, sp500$raw, penalty = penalty)
122 | sp500$estimate <- approx(soln$x, soln$pred,
123 | xout = sp500$x,
124 | method = "linear", rule = 2)$y
125 | sp500$group <- as.character(
126 | findInterval(sp500$x, soln[soln$what=="left", "x"]))
127 |
128 | ggplot(data = sp500, aes(x = date)) +
129 | geom_line(aes(y=raw), color = "lightgray") +
130 | geom_line(aes(y=estimate, color = group)) +
131 | ggtitle("segment approximation of historic data",
132 | subtitle = paste("per-segment penalty =", penalty)) +
133 | theme(legend.position = "none") +
134 | scale_color_brewer(palette = "Dark2")
135 |
136 | ```
137 |
--------------------------------------------------------------------------------
/extras/PseudoInverse.tex:
--------------------------------------------------------------------------------
1 |
2 | \documentclass{article}
3 |
4 | \usepackage{hyperref}
5 | \usepackage{amsmath}
6 | \usepackage{amssymb}
7 |
8 | \newtheorem{theorem}{Theorem}
9 |
10 | \begin{document}
11 |
12 | \title{The 2 by 2 Real Pseudo Inverse}
13 | \author{John Mount}
14 | \date{2019-01-07}
15 |
16 |
17 |
18 |
19 | \maketitle
20 |
21 |
22 | This is a brief note on the math behind the direct
23 | PRESS statistic calculation\footnote{\url{http://www.win-vector.com/blog/2014/09/estimating-generalization-error-with-the-press-statistic/}}
24 | found in the RcppDynProg package\footnote{\url{https://github.com/WinVector/RcppDynProg}}.
25 |
26 | The actual `C++` code\footnote{\url{https://github.com/WinVector/RcppDynProg/blob/master/src/xlin_fits.cpp}} is a bit ugly and intimidating. That is because we are using a verbose scalar notation to represent matrix concepts. In matrix notation we are solving a linear system by inverting a two by two matrix.\footnote{Yes, there are the usual admonitions that one should not invert a matrix to solve a linear system, but for systems this small they do not apply.} We are in turn inverting the two by two matrix by exploiting the following well know rule of how to invert a two by two matrix.
27 |
28 |
29 | If $a d - b c$ is not zero then:
30 |
31 | \[
32 | \begin{pmatrix} a & b \\ c & d \end{pmatrix}^{-1}
33 | =
34 | \frac{1}{a d - b c}
35 | \begin{pmatrix} d & -b \\ -c & a \end{pmatrix}
36 | \]
37 |
38 | Throughout $a$, $b$, $c$, and $d$ all real scalars.
39 |
40 | This can be re-written as the following general relation.
41 |
42 | \[
43 | \begin{pmatrix} a & b \\ c & d \end{pmatrix}
44 | \begin{pmatrix} d & -b \\ -c & a \end{pmatrix}
45 | =
46 | (a d - b c)
47 | \begin{pmatrix} 1 & 0 \\ 0 & 1 \end{pmatrix}
48 | \]
49 |
50 | The above can be directly checked just by applying the rules for multiplying matrices to the left two matrices. This has a particularly pleasant presentation if we recognize that $a d - b c$ is the determinant of the left matrix and use the traditional vertical bar determinant notation.
51 |
52 | \[
53 | \begin{pmatrix} a & b \\ c & d \end{pmatrix}
54 | \begin{pmatrix} d & -b \\ -c & a \end{pmatrix}
55 | =
56 | \begin{vmatrix} a & b \\ c & d \end{vmatrix}
57 | \begin{pmatrix} 1 & 0 \\ 0 & 1 \end{pmatrix}
58 | \]
59 |
60 |
61 |
62 | Now there is an issue of what to do when $a d - b c$ is zero. For our implementation we apply Tikhonov regularization\footnote{\url{https://en.wikipedia.org/wiki/Tikhonov_regularization}} which (barring the exact numeric coincidence of minus two times the expected value of the independent variable equaling our regularization constant) is going to be non-singular. For our actual application, we could simply switch degenerate situations to the out-of sample mean implementation\footnote{\url{https://github.com/WinVector/RcppDynProg/blob/master/src/const_costs.cpp}}.
63 |
64 | But, for fun, let's play with the math a bit.
65 |
66 | There is an additional lesser known algebraic relation for two by two matrices.
67 |
68 |
69 | \[
70 | \begin{pmatrix} a & b \\ c & d \end{pmatrix}
71 | \begin{pmatrix} a & c \\ b & d \end{pmatrix}
72 | \begin{pmatrix} a & b \\ c & d \end{pmatrix}
73 | =
74 | (a^2 + b^2 + c^2 + d^2)
75 | \begin{pmatrix} a & b \\ c & d \end{pmatrix}
76 | +
77 | (a d - b c)
78 | \begin{pmatrix} -d & c \\ b & -a \end{pmatrix}
79 | \]
80 |
81 | Or (using transpose, matrix squared Frobenius norm, and determinant notation):
82 |
83 | \begin{theorem}
84 | For any real 2 by 2 matrix
85 | $\begin{pmatrix} a & b \\ c & d \end{pmatrix}$ we have:
86 |
87 |
88 | \[
89 | \begin{pmatrix} a & b \\ c & d \end{pmatrix}
90 | \begin{pmatrix} a & b \\ c & d \end{pmatrix}^{\top}
91 | \begin{pmatrix} a & b \\ c & d \end{pmatrix}
92 | =
93 | \begin{Vmatrix} a & b \\ c & d \end{Vmatrix}_2^2
94 | \begin{pmatrix} a & b \\ c & d \end{pmatrix}
95 | +
96 | \begin{vmatrix} a & b \\ c & d \end{vmatrix}
97 | \begin{pmatrix} -d & c \\ b & -a \end{pmatrix}
98 | \].
99 | The superscript "top" denoting the transpose operation, the $||.||^2_2$ denoting sum of squares norm, and the single $|.|$ denoting determinant.
100 | \\ $\square$
101 | \label{thm:fmla}
102 | \end{theorem}
103 |
104 |
105 | This means, if $a d - b c$ is zero then:
106 |
107 |
108 | \[
109 | \begin{pmatrix} a & b \\ c & d \end{pmatrix}
110 | \begin{pmatrix} a & b \\ c & d \end{pmatrix}^{\top}
111 | \begin{pmatrix} a & b \\ c & d \end{pmatrix}
112 | =
113 | \begin{Vmatrix} a & b \\ c & d \end{Vmatrix}_2^2
114 | \begin{pmatrix} a & b \\ c & d \end{pmatrix}
115 | \]
116 |
117 |
118 | Once we [confirm the above relation\footnote{\url{https://github.com/WinVector/RcppDynProg/blob/master/extras/PseudoInverse.ipynb}} we can also confirm that if $a^2 + b^2 + c^2 + d^2$ is not zero, then the following matrix:
119 |
120 | \[
121 | \begin{pmatrix} a & b \\ c & d \end{pmatrix}^{+}
122 | =
123 | \frac{1}{a^2 + b^2 + c^2 + d^2}
124 | \begin{pmatrix} a & c \\ b & d \end{pmatrix}
125 | \]
126 |
127 | satisfies all of the conditions for being the Moore-Penrose inverse\footnote{\url{https://en.wikipedia.org/wiki/Moore–Penrose_inverse}} (or pseudo-inverse) of our original matrix. The superscript-plus denoting the Moore-Penrose inverse operation.
128 |
129 | Or in transpose notation:
130 |
131 | \[
132 | \begin{pmatrix} a & b \\ c & d \end{pmatrix}^{+}
133 | =
134 | \frac{1}{a^2 + b^2 + c^2 + d^2}
135 | \begin{pmatrix} a & b \\ c & d \end{pmatrix}^{\top}
136 | \]
137 |
138 | This is called the pseudo-inverse because it acts like an inverse, even for non-invertible matrices. For $A^{+}$ to be
139 | a More-Penrose inverse we must confirm it obeys the following relations:
140 |
141 | \begin{align*}
142 | A A^{+} A &= A \\
143 | A^{+} A A^{+} &= A^{+} \\
144 | (A A^{+})^{\top} &= A A^{+} \\
145 | (A^{+} A)^{\top} &= A^{+} A
146 | \end{align*}
147 |
148 | Theorem \ref{thm:fmla} lets us check the first relation, the other follow quickly as our $A^{+}$ is a simple scalar multiple of the transpose.\footnote{With the same scaling for both $A^{+}$ and $(A^{\top})^{+}$.}
149 |
150 | All of the above check relations would be true for a classic inverse. We can think of $A^{+}$ as almost canceling a single $A$ to the left or the $A$ to the right.
151 |
152 |
153 | \begin{theorem}
154 | For any real 2 by 2 matrix $\begin{pmatrix} a & b \\ c & d \end{pmatrix}$
155 |
156 | The Moore-Penrose inverse is:
157 |
158 |
159 | \begin{itemize}
160 |
161 |
162 | \item When $a d - b c$ is not zero:
163 |
164 | \[
165 | \frac{1}{a d - b c}
166 | \begin{pmatrix} d & -b \\ -c & a \end{pmatrix}
167 | \]
168 |
169 | \item When $a d - b c$ is zero and $a^2 + b^2 + c^2 + d^2$ is not zero:
170 |
171 | \[
172 | \frac{1}{a^2 + b^2 + c^2 + d^2}
173 | \begin{pmatrix} a & c \\ b & d \end{pmatrix}
174 | \]
175 |
176 | \item Otherwise:
177 |
178 | \[
179 | \begin{pmatrix} 0 & 0 \\ 0 & 0 \end{pmatrix}
180 | \]
181 | \end{itemize}
182 | .
183 | \\ $\square$
184 | \end{theorem}
185 |
186 | For general matrices the situation is much more complicated.
187 |
188 | The wealth of symmetries and relations is really kind of neat.
189 |
190 |
191 |
192 |
193 | \end{document}
194 |
--------------------------------------------------------------------------------
/docs/reference/RcppDynProg.html:
--------------------------------------------------------------------------------
1 |
2 |
3 |
4 |
5 |
6 |
7 |
8 |
9 | RcppDynProg — RcppDynProg • RcppDynProg
10 |
11 |
12 |
13 |
14 |
15 |
16 |
17 |
18 |
19 |
20 |
21 |
22 |
23 |
24 |
25 |
26 |
27 |
28 |
29 |
30 |
31 |
32 |
33 |
34 |
35 |
36 |
37 |
38 |
39 |
40 |
41 |
42 |
43 |
47 |
48 |
49 |
50 |
51 |
52 |
53 |
54 |
55 |
59 |
60 |
61 |
62 |
63 |
64 |
65 |
66 |
67 |
124 |
125 |
126 |
127 |
128 |
129 |
130 |
131 |
136 |
137 |
138 | Rcpp dynamic programming solutions for partitioning and machine learning problems.
139 | Includes out of sample fitting applications.
140 | Also supplies additional custom coders for the vtreat package.
141 | Please see https://github.com/WinVector/RcppDynProg for details.
142 |
143 |
144 |
145 |
146 | Author
147 |
148 | John Mount
149 |
150 |
151 |
156 |
157 |
158 |
159 |
169 |
170 |
171 |
172 |
173 |
174 |
175 |
176 |
177 |
178 |
--------------------------------------------------------------------------------
57 |
75 |
76 |
77 |
58 |
74 |
59 |
61 |
62 | Articles
60 |
63 |
73 | All vignettes
64 | 65 | 66 |- RcppDynProg package 67 |
- 68 |
- Segmentation 69 |
- 70 |
- Linear Segmentation 71 |
- 72 |
81 |
96 |
97 |
98 |
99 |
110 |
82 |
89 |
90 |
94 |
95 |
83 |
85 |
86 | Content not found. Please use links in the navbar.
87 |
88 | Page not found (404)
84 || \n", 61 | " | x | \n", 62 | "y_ideal | \n", 63 | "y_observed | \n", 64 | "
|---|---|---|---|
| 0 | \n", 69 | "0.05 | \n", 70 | "0.000225 | \n", 71 | "0.041055 | \n", 72 | "
| 1 | \n", 75 | "0.10 | \n", 76 | "0.000900 | \n", 77 | "0.502473 | \n", 78 | "
| 2 | \n", 81 | "0.15 | \n", 82 | "0.002025 | \n", 83 | "-0.027719 | \n", 84 | "
| 3 | \n", 87 | "0.20 | \n", 88 | "0.003600 | \n", 89 | "-0.260338 | \n", 90 | "
| 4 | \n", 93 | "0.25 | \n", 94 | "0.005625 | \n", 95 | "0.308052 | \n", 96 | "
82 |
105 |
106 |
107 |
108 |
119 |
83 |
99 |
100 |
103 |
104 |
84 |
91 |
92 |
93 |
94 |
95 |
96 | RcppDynProg package
85 |John Mount
86 | 87 |2023-08-19
88 | 89 | Source:vignettes/RcppDynProg.Rmd
90 | RcppDynProg.RmdThis content has moved to the package 97 | README.
98 |
130 |
157 |
158 |
159 |
169 |
131 |
136 |
137 |
151 |
156 |
138 |
143 |
144 |
145 |
146 | Rcpp dynamic programming solutions for partitioning and machine learning problems. 139 | Includes out of sample fitting applications. 140 | Also supplies additional custom coders for the vtreat package. 141 | Please see https://github.com/WinVector/RcppDynProg for details.
142 |Author
147 | 148 |John Mount
149 | 150 |