From 34528cb00d8b54386cf5a0a81ceb419704d56e1b Mon Sep 17 00:00:00 2001 From: Bert Date: Tue, 21 Jul 2020 19:44:00 +0800 Subject: [PATCH 01/11] Update wtd.stats.s patching the lowest index 1 --- R/wtd.stats.s | 10 +--------- 1 file changed, 1 insertion(+), 9 deletions(-) diff --git a/R/wtd.stats.s b/R/wtd.stats.s index f84dea91..3ea16e56 100644 --- a/R/wtd.stats.s +++ b/R/wtd.stats.s @@ -70,16 +70,8 @@ wtd.quantile <- function(x, weights=NULL, probs=c(0, .25, .5, .75, 1), x <- w$x wts <- w$sum.of.weights n <- sum(wts) - order <- 1 + (n - 1) * probs - low <- pmax(floor(order), 1) - high <- pmin(low + 1, n) - order <- order %% 1 - ## Find low and high order statistics - ## These are minimum values of x such that the cum. freqs >= c(low,high) - allq <- approx(cumsum(wts), x, xout=c(low,high), + quantiles <- approx(cumsum(wts), x, xout=probs*n, method='constant', f=1, rule=2)$y - k <- length(probs) - quantiles <- (1 - order)*allq[1:k] + order*allq[-(1:k)] names(quantiles) <- nams return(quantiles) } From bb3d251fb7ee814cf07045ee725072f51a368c75 Mon Sep 17 00:00:00 2001 From: Bert Date: Tue, 21 Jul 2020 20:37:33 +0800 Subject: [PATCH 02/11] Update wtd.stats.s change linear --- R/wtd.stats.s | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/R/wtd.stats.s b/R/wtd.stats.s index 3ea16e56..a6ef3902 100644 --- a/R/wtd.stats.s +++ b/R/wtd.stats.s @@ -71,7 +71,7 @@ wtd.quantile <- function(x, weights=NULL, probs=c(0, .25, .5, .75, 1), wts <- w$sum.of.weights n <- sum(wts) quantiles <- approx(cumsum(wts), x, xout=probs*n, - method='constant', f=1, rule=2)$y + method='linear', f=1, rule=2)$y names(quantiles) <- nams return(quantiles) } From 20e6895f444a8065a9fb7b07884cb8f46b257d29 Mon Sep 17 00:00:00 2001 From: Bert Date: Tue, 21 Jul 2020 22:33:26 +0800 Subject: [PATCH 03/11] Update wtd.stats.s Update the function according to https://stats.stackexchange.com/questions/13169/defining-quantiles-over-a-weighted-sample formula --- R/wtd.stats.s | 13 +++++++++++-- 1 file changed, 11 insertions(+), 2 deletions(-) diff --git a/R/wtd.stats.s b/R/wtd.stats.s index a6ef3902..f525eabb 100644 --- a/R/wtd.stats.s +++ b/R/wtd.stats.s @@ -69,8 +69,17 @@ wtd.quantile <- function(x, weights=NULL, probs=c(0, .25, .5, .75, 1), w <- wtd.table(x, weights, na.rm=na.rm, normwt=normwt, type='list') x <- w$x wts <- w$sum.of.weights - n <- sum(wts) - quantiles <- approx(cumsum(wts), x, xout=probs*n, + weighted_S = c() + cum_w <- cumsum(wts) + for (i in c(1:length(wts))){ + if (i > 1){ + Sk = (i-1) * wts[i] + (length(wts)-1) * cum_w[i-1]} + else{ + Sk = 0 + } + weighted_S = append(weighted_S, Sk) + } + allq <- approx(weighted_S, x, xout=probs*weighted_S[length(weighted_S)], method='linear', f=1, rule=2)$y names(quantiles) <- nams return(quantiles) From 3fc06b2034647cb403e472268cabea66263643c3 Mon Sep 17 00:00:00 2001 From: Bert Date: Sat, 25 Jul 2020 01:26:59 +0800 Subject: [PATCH 04/11] Update wtd.stats.s Update naming --- R/wtd.stats.s | 10 +++++----- 1 file changed, 5 insertions(+), 5 deletions(-) diff --git a/R/wtd.stats.s b/R/wtd.stats.s index f525eabb..c6952b33 100644 --- a/R/wtd.stats.s +++ b/R/wtd.stats.s @@ -69,17 +69,17 @@ wtd.quantile <- function(x, weights=NULL, probs=c(0, .25, .5, .75, 1), w <- wtd.table(x, weights, na.rm=na.rm, normwt=normwt, type='list') x <- w$x wts <- w$sum.of.weights - weighted_S = c() + weighted_s = c() cum_w <- cumsum(wts) for (i in c(1:length(wts))){ if (i > 1){ - Sk = (i-1) * wts[i] + (length(wts)-1) * cum_w[i-1]} + sk = (i-1) * wts[i] + (length(wts)-1) * cum_w[i-1]} else{ - Sk = 0 + sk = 0 } - weighted_S = append(weighted_S, Sk) + weighted_s = append(weighted_s, sk) } - allq <- approx(weighted_S, x, xout=probs*weighted_S[length(weighted_S)], + allq <- approx(weighted_s, x, xout=probs*weighted_s[length(weighted_s)], method='linear', f=1, rule=2)$y names(quantiles) <- nams return(quantiles) From 140af36f036bf901430dcdd92538897e2c1af7fc Mon Sep 17 00:00:00 2001 From: Bert Date: Tue, 21 Jul 2020 20:37:33 +0800 Subject: [PATCH 05/11] Update wtd.stats.s coding change linear Update wtd.stats.s Update the function according to https://stats.stackexchange.com/questions/13169/defining-quantiles-over-a-weighted-sample formula Update wtd.stats.s Update naming --- R/wtd.stats.s | 15 ++++++++++++--- 1 file changed, 12 insertions(+), 3 deletions(-) diff --git a/R/wtd.stats.s b/R/wtd.stats.s index 3ea16e56..c6952b33 100644 --- a/R/wtd.stats.s +++ b/R/wtd.stats.s @@ -69,9 +69,18 @@ wtd.quantile <- function(x, weights=NULL, probs=c(0, .25, .5, .75, 1), w <- wtd.table(x, weights, na.rm=na.rm, normwt=normwt, type='list') x <- w$x wts <- w$sum.of.weights - n <- sum(wts) - quantiles <- approx(cumsum(wts), x, xout=probs*n, - method='constant', f=1, rule=2)$y + weighted_s = c() + cum_w <- cumsum(wts) + for (i in c(1:length(wts))){ + if (i > 1){ + sk = (i-1) * wts[i] + (length(wts)-1) * cum_w[i-1]} + else{ + sk = 0 + } + weighted_s = append(weighted_s, sk) + } + allq <- approx(weighted_s, x, xout=probs*weighted_s[length(weighted_s)], + method='linear', f=1, rule=2)$y names(quantiles) <- nams return(quantiles) } From 5163a3fdedab9ed52ea7626038e10581a7501cdc Mon Sep 17 00:00:00 2001 From: Bert Date: Tue, 21 Jul 2020 20:37:33 +0800 Subject: [PATCH 06/11] Update the function according to https://stats.stackexchange.com/questions/13169/defining-quantiles-over-a-weighted-sample formula --- R/wtd.stats.s | 38 +++++++++++++++++++++++++++++++++++++- 1 file changed, 37 insertions(+), 1 deletion(-) diff --git a/R/wtd.stats.s b/R/wtd.stats.s index 3ea16e56..c463b79c 100644 --- a/R/wtd.stats.s +++ b/R/wtd.stats.s @@ -69,9 +69,45 @@ wtd.quantile <- function(x, weights=NULL, probs=c(0, .25, .5, .75, 1), w <- wtd.table(x, weights, na.rm=na.rm, normwt=normwt, type='list') x <- w$x wts <- w$sum.of.weights +<<<<<<< HEAD +<<<<<<< HEAD +<<<<<<< HEAD + weighted_s = c() + cum_w <- cumsum(wts) + for (i in c(1:length(wts))){ + if (i > 1){ + sk = (i-1) * wts[i] + (length(wts)-1) * cum_w[i-1]} + else{ + sk = 0 + } + weighted_s = append(weighted_s, sk) + } + allq <- approx(weighted_s, x, xout=probs*weighted_s[length(weighted_s)], +======= n <- sum(wts) quantiles <- approx(cumsum(wts), x, xout=probs*n, - method='constant', f=1, rule=2)$y +>>>>>>> bb3d251... Update wtd.stats.s +======= + weighted_S = c() +======= + weighted_s = c() +>>>>>>> 3fc06b2... Update wtd.stats.s + cum_w <- cumsum(wts) + for (i in c(1:length(wts))){ + if (i > 1){ + sk = (i-1) * wts[i] + (length(wts)-1) * cum_w[i-1]} + else{ + sk = 0 + } + weighted_s = append(weighted_s, sk) + } +<<<<<<< HEAD + allq <- approx(weighted_S, x, xout=probs*weighted_S[length(weighted_S)], +>>>>>>> 20e6895... Update wtd.stats.s +======= + allq <- approx(weighted_s, x, xout=probs*weighted_s[length(weighted_s)], +>>>>>>> 3fc06b2... Update wtd.stats.s + method='linear', f=1, rule=2)$y names(quantiles) <- nams return(quantiles) } From ad2e7cf5a7d8a230c5058d24e6045250d3822fc4 Mon Sep 17 00:00:00 2001 From: Bert Date: Sat, 25 Jul 2020 02:04:38 +0800 Subject: [PATCH 07/11] Update wtd.stats.s --- R/wtd.stats.s | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/R/wtd.stats.s b/R/wtd.stats.s index c6952b33..b9a1b5fc 100644 --- a/R/wtd.stats.s +++ b/R/wtd.stats.s @@ -79,7 +79,7 @@ wtd.quantile <- function(x, weights=NULL, probs=c(0, .25, .5, .75, 1), } weighted_s = append(weighted_s, sk) } - allq <- approx(weighted_s, x, xout=probs*weighted_s[length(weighted_s)], + quantiles <- approx(weighted_s, x, xout=probs*weighted_s[length(weighted_s)], method='linear', f=1, rule=2)$y names(quantiles) <- nams return(quantiles) From 43f361c654def449c746a0b043f3c9b996c802f3 Mon Sep 17 00:00:00 2001 From: iii-org-tw <67881762+iii-org-tw@users.noreply.github.com> Date: Wed, 29 Jul 2020 04:36:09 +0800 Subject: [PATCH 08/11] Update wtd.stats.s --- R/wtd.stats.s | 3 +++ 1 file changed, 3 insertions(+) diff --git a/R/wtd.stats.s b/R/wtd.stats.s index b9a1b5fc..11fa7d67 100644 --- a/R/wtd.stats.s +++ b/R/wtd.stats.s @@ -79,6 +79,9 @@ wtd.quantile <- function(x, weights=NULL, probs=c(0, .25, .5, .75, 1), } weighted_s = append(weighted_s, sk) } + print (weighted_s) + print (x) + print (wts) quantiles <- approx(weighted_s, x, xout=probs*weighted_s[length(weighted_s)], method='linear', f=1, rule=2)$y names(quantiles) <- nams From 7444fa77ee2000d7e38c3329b81522d0bd734607 Mon Sep 17 00:00:00 2001 From: iii-org-tw <67881762+iii-org-tw@users.noreply.github.com> Date: Wed, 29 Jul 2020 04:48:38 +0800 Subject: [PATCH 09/11] Update wtd.stats.s --- R/wtd.stats.s | 26 +++++++++++--------------- 1 file changed, 11 insertions(+), 15 deletions(-) diff --git a/R/wtd.stats.s b/R/wtd.stats.s index 11fa7d67..f84dea91 100644 --- a/R/wtd.stats.s +++ b/R/wtd.stats.s @@ -69,21 +69,17 @@ wtd.quantile <- function(x, weights=NULL, probs=c(0, .25, .5, .75, 1), w <- wtd.table(x, weights, na.rm=na.rm, normwt=normwt, type='list') x <- w$x wts <- w$sum.of.weights - weighted_s = c() - cum_w <- cumsum(wts) - for (i in c(1:length(wts))){ - if (i > 1){ - sk = (i-1) * wts[i] + (length(wts)-1) * cum_w[i-1]} - else{ - sk = 0 - } - weighted_s = append(weighted_s, sk) - } - print (weighted_s) - print (x) - print (wts) - quantiles <- approx(weighted_s, x, xout=probs*weighted_s[length(weighted_s)], - method='linear', f=1, rule=2)$y + n <- sum(wts) + order <- 1 + (n - 1) * probs + low <- pmax(floor(order), 1) + high <- pmin(low + 1, n) + order <- order %% 1 + ## Find low and high order statistics + ## These are minimum values of x such that the cum. freqs >= c(low,high) + allq <- approx(cumsum(wts), x, xout=c(low,high), + method='constant', f=1, rule=2)$y + k <- length(probs) + quantiles <- (1 - order)*allq[1:k] + order*allq[-(1:k)] names(quantiles) <- nams return(quantiles) } From cdc846d261abc09fe2e7dcb05219447159751c7a Mon Sep 17 00:00:00 2001 From: iii-org-tw <67881762+iii-org-tw@users.noreply.github.com> Date: Wed, 29 Jul 2020 04:49:12 +0800 Subject: [PATCH 10/11] Update wtd.stats.s --- R/wtd.stats.s | 2 ++ 1 file changed, 2 insertions(+) diff --git a/R/wtd.stats.s b/R/wtd.stats.s index f84dea91..ee26a3b6 100644 --- a/R/wtd.stats.s +++ b/R/wtd.stats.s @@ -70,6 +70,8 @@ wtd.quantile <- function(x, weights=NULL, probs=c(0, .25, .5, .75, 1), x <- w$x wts <- w$sum.of.weights n <- sum(wts) + print (x) + print (wts) order <- 1 + (n - 1) * probs low <- pmax(floor(order), 1) high <- pmin(low + 1, n) From dcc1964b6a6b0c327e643034a2a5fa5d8873adcd Mon Sep 17 00:00:00 2001 From: iii-org-tw <67881762+iii-org-tw@users.noreply.github.com> Date: Wed, 29 Jul 2020 17:50:36 +0800 Subject: [PATCH 11/11] Update wtd.stats.s --- R/wtd.stats.s | 31 +++++++++++++++---------------- 1 file changed, 15 insertions(+), 16 deletions(-) diff --git a/R/wtd.stats.s b/R/wtd.stats.s index ee26a3b6..4558c47e 100644 --- a/R/wtd.stats.s +++ b/R/wtd.stats.s @@ -66,22 +66,21 @@ wtd.quantile <- function(x, weights=NULL, probs=c(0, .25, .5, .75, 1), weights <- weights[! i] } if(type == 'quantile') { - w <- wtd.table(x, weights, na.rm=na.rm, normwt=normwt, type='list') - x <- w$x - wts <- w$sum.of.weights - n <- sum(wts) - print (x) - print (wts) - order <- 1 + (n - 1) * probs - low <- pmax(floor(order), 1) - high <- pmin(low + 1, n) - order <- order %% 1 - ## Find low and high order statistics - ## These are minimum values of x such that the cum. freqs >= c(low,high) - allq <- approx(cumsum(wts), x, xout=c(low,high), - method='constant', f=1, rule=2)$y - k <- length(probs) - quantiles <- (1 - order)*allq[1:k] + order*allq[-(1:k)] + sorted_xi = sort(x, index.return=TRUE) + sorted_x = sorted_xi$x + sorted_weights = weights[sorted_xi$ix] + weighted_s = c() + cum_w <- cumsum(sorted_weights) + for (i in c(1:length(sorted_weights))){ + if (i > 1){ + sk = (i-1) * sorted_weights[i] + (length(sorted_weights)-1) * cum_w[i-1]} + else{ + sk = 0 + } + weighted_s = append(weighted_s, sk) + } + quantiles <- approx(weighted_s, sorted_x, xout=probs*weighted_s[length(weighted_s)], + method='linear', f=1, rule=2)$y names(quantiles) <- nams return(quantiles) }