annotate , xlab , ylab , scale_color_hue, size, legend, 日本語 , 人口

 

pref_db %>% head(.,10)

   region x2010 x2015 x2016 x2017  size
2  北海道  5506  5382  5352  5320 83457
3  青森県  1373  1308  1293  1278  9645
4  岩手県  1330  1280  1268  1255 15279
5  宮城県  2348  2334  2330  2323  6862
6  秋田県  1086  1023  1010   996 11636
7  山形県  1169  1124  1113  1102  6652
8  福島県  2029  1914  1901  1882 13783
9  茨城県  2970  2917  2905  2892  6096
10 栃木県  2008  1974  1966  1957  6408
11 群馬県  2008  1973  1967  1960  6362

df <- data.frame(case_per_capita=as.vector(apply(mdf[,-48],2,sum) / pref_db$x2017),pop_density=pref_db$x2017/pref_db$size,sign=pref_db$x2017,r=pref_db[,1])

x1 <- df[,2]

y1 <- df[,1]

df <- cbind(df,lm=predict(nls(y1~a*x1^(1/4)+b,start=c(a=1,b=1),trace=TRUE)))

p <- ggplot(df, aes(x=pop_density))

p <- p + xlab("人口密度") + ylab("人口あたり件数")

p <- p + geom_point(aes(y=case_per_capita,size=sign,color=r),alpha=1)

p <- p+annotate("text",label=pref_db[,1],x=df[,2], y=df[,1]+0.1,colour='black',family = "HiraKakuProN-W3",size=3)

p <- p + geom_line(aes(y=lm))

p <- p + theme_gray (base_family = "HiraKakuPro-W3")

p <- p + scale_color_hue(name="都道府県",labels=pref_db[,1])

# p <- p + guides(fill = guide_legend(reverse = F,order = 2),label = TRUE)

p <- p + guides(size = guide_legend(title="人口"))

# don't forget to set "color=". otherwise fails to show up.

p <- p + geom_smooth(aes(x=pop_density,y=case_per_capita),method = "lm",se=F,color="red",size=0.5)

# p + scale_colour_manual(values = pref_db[,3])

plot(p)

vaccine ワクチン

from here

 

 

dplyr filter arrange 行列 内積

 

dplyr::filter(js,prefecture==35) %>% dplyr::group_by(.,date) %>% dplyr::summarise(.,sum(count)) %>% last(.,20)

w <- ((dplyr::arrange(df.melt,t))[,3] %>% matrix(.,nrow=8) %>% t())%*% matrix(c(0, 0, 0, 0.001, 0.003, 0.014, 0.048, 0.125 ),ncol=1) 

dplyr::group_by(js,date,prefecture) %>% dplyr::summarise(.,sum(count))

# key を複数取るとことができる。primary key , sub key の順番？

行列 転置 問題 バグ？

 
len <- 5
mdf <- matrix(1:60,ncol=12,byrow=T)

> ((mdf %>% last(.,len) %>% t() %>% as.vector()) /rep(1:12 ,len)   %>% matrix(.,nrow=12)) 
      [,1]      [,2]      [,3]      [,4]      [,5]
 [1,]    1 13.000000 25.000000 37.000000 49.000000
 [2,]    1  7.000000 13.000000 19.000000 25.000000
 [3,]    1  5.000000  9.000000 13.000000 17.000000
 [4,]    1  4.000000  7.000000 10.000000 13.000000
 [5,]    1  3.400000  5.800000  8.200000 10.600000
 [6,]    1  3.000000  5.000000  7.000000  9.000000
 [7,]    1  2.714286  4.428571  6.142857  7.857143
 [8,]    1  2.500000  4.000000  5.500000  7.000000
 [9,]    1  2.333333  3.666667  5.000000  6.333333
[10,]    1  2.200000  3.400000  4.600000  5.800000
[11,]    1  2.090909  3.181818  4.272727  5.363636
[12,]    1  2.000000  3.000000  4.000000  5.000000
> (mdf %>% last(.,len) %>% t() %>% as.vector()) /rep(1:12 ,len)   %>% matrix(.,nrow=12)
      [,1]      [,2]      [,3]      [,4]      [,5]
 [1,]    1 13.000000 25.000000 37.000000 49.000000
 [2,]    1  7.000000 13.000000 19.000000 25.000000
 [3,]    1  5.000000  9.000000 13.000000 17.000000
 [4,]    1  4.000000  7.000000 10.000000 13.000000
 [5,]    1  3.400000  5.800000  8.200000 10.600000
 [6,]    1  3.000000  5.000000  7.000000  9.000000
 [7,]    1  2.714286  4.428571  6.142857  7.857143
 [8,]    1  2.500000  4.000000  5.500000  7.000000
 [9,]    1  2.333333  3.666667  5.000000  6.333333
[10,]    1  2.200000  3.400000  4.600000  5.800000
[11,]    1  2.090909  3.181818  4.272727  5.363636
[12,]    1  2.000000  3.000000  4.000000  5.000000

# Correct!! use parse before pipe to t()
> ((mdf %>% last(.,len) %>% t() %>% as.vector()) /rep(1:12 ,len)   %>% matrix(.,nrow=12)) %>% t()
     [,1] [,2] [,3] [,4] [,5] [,6]     [,7] [,8]     [,9] [,10]    [,11] [,12]
[1,]    1    1    1    1  1.0    1 1.000000  1.0 1.000000   1.0 1.000000     1
[2,]   13    7    5    4  3.4    3 2.714286  2.5 2.333333   2.2 2.090909     2
[3,]   25   13    9    7  5.8    5 4.428571  4.0 3.666667   3.4 3.181818     3
[4,]   37   19   13   10  8.2    7 6.142857  5.5 5.000000   4.6 4.272727     4
[5,]   49   25   17   13 10.6    9 7.857143  7.0 6.333333   5.8 5.363636     5

# WRONG!!
> (mdf %>% last(.,len) %>% t() %>% as.vector()) /rep(1:12 ,len)   %>% matrix(.,nrow=12) %>% t()
     [,1] [,2]     [,3] [,4] [,5]     [,6]     [,7]  [,8]     [,9] [,10]    [,11]    [,12]
[1,]    1  3.0 3.666667 4.00  4.2 4.333333 4.428571 4.500 4.555556   4.6 4.636364 4.666667
[2,]    2  3.5 4.000000 4.25  4.4 4.500000 4.571429 4.625 4.666667   4.7 4.727273 4.750000
[3,]    3  4.0 4.333333 4.50  4.6 4.666667 4.714286 4.750 4.777778   4.8 4.818182 4.833333
[4,]    4  4.5 4.666667 4.75  4.8 4.833333 4.857143 4.875 4.888889   4.9 4.909091 4.916667
[5,]    5  5.0 5.000000 5.00  5.0 5.000000 5.000000 5.000 5.000000   5.0 5.000000 5.000000

>  ((mdf %>% last(.,len) %>% t() %>% as.vector()) /1:12)  %>% matrix(.,nrow=12)    

      [,1]      [,2]      [,3]      [,4]      [,5]

 [1,]    1 13.000000 25.000000 37.000000 49.000000

 [2,]    1  7.000000 13.000000 19.000000 25.000000

 [3,]    1  5.000000  9.000000 13.000000 17.000000

 [4,]    1  4.000000  7.000000 10.000000 13.000000

 [5,]    1  3.400000  5.800000  8.200000 10.600000

 [6,]    1  3.000000  5.000000  7.000000  9.000000

 [7,]    1  2.714286  4.428571  6.142857  7.857143

 [8,]    1  2.500000  4.000000  5.500000  7.000000

 [9,]    1  2.333333  3.666667  5.000000  6.333333

[10,]    1  2.200000  3.400000  4.600000  5.800000

[11,]    1  2.090909  3.181818  4.272727  5.363636

[12,]    1  2.000000  3.000000  4.000000  5.000000

>  ((mdf %>% last(.,len) %>% t() %>% as.vector()) /1:12)  %>% matrix(.,nrow=12)    %>% t()  #OK

     [,1] [,2] [,3] [,4] [,5] [,6]     [,7] [,8]     [,9] [,10]    [,11] [,12]

[1,]    1    1    1    1  1.0    1 1.000000  1.0 1.000000   1.0 1.000000     1

[2,]   13    7    5    4  3.4    3 2.714286  2.5 2.333333   2.2 2.090909     2

[3,]   25   13    9    7  5.8    5 4.428571  4.0 3.666667   3.4 3.181818     3

[4,]   37   19   13   10  8.2    7 6.142857  5.5 5.000000   4.6 4.272727     4

[5,]   49   25   17   13 10.6    9 7.857143  7.0 6.333333   5.8 5.363636     5

>  len

[1] 5

>  (mdf %>% last(.,len) %>% t() %>% as.vector()) /rep(seq(1,12,1),len)  %>% matrix(.,nrow=12)    %>% t() #WRONG

     [,1] [,2]     [,3] [,4] [,5]     [,6]     [,7]  [,8]     [,9] [,10]    [,11]    [,12]

[1,]    1  3.0 3.666667 4.00  4.2 4.333333 4.428571 4.500 4.555556   4.6 4.636364 4.666667

[2,]    2  3.5 4.000000 4.25  4.4 4.500000 4.571429 4.625 4.666667   4.7 4.727273 4.750000

[3,]    3  4.0 4.333333 4.50  4.6 4.666667 4.714286 4.750 4.777778   4.8 4.818182 4.833333

[4,]    4  4.5 4.666667 4.75  4.8 4.833333 4.857143 4.875 4.888889   4.9 4.909091 4.916667

[5,]    5  5.0 5.000000 5.00  5.0 5.000000 5.000000 5.000 5.000000   5.0 5.000000 5.000000

>  ( (mdf %>% last(.,len) %>% t() %>% as.vector()) /rep(seq(1,12,1),len) ) %>% matrix(.,nrow=12)    %>% t() #OK

     [,1] [,2] [,3] [,4] [,5] [,6]     [,7] [,8]     [,9] [,10]    [,11] [,12]

[1,]    1    1    1    1  1.0    1 1.000000  1.0 1.000000   1.0 1.000000     1

[2,]   13    7    5    4  3.4    3 2.714286  2.5 2.333333   2.2 2.090909     2

[3,]   25   13    9    7  5.8    5 4.428571  4.0 3.666667   3.4 3.181818     3

[4,]   37   19   13   10  8.2    7 6.142857  5.5 5.000000   4.6 4.272727     4

[5,]   49   25   17   13 10.6    9 7.857143  7.0 6.333333   5.8 5.363636     5

1990年以降、景気後退期を除き、 VIX が40％急上昇した後の6カ月間にS&P500は平均10％のリターンを記録していると

1. VIXの2営業日前との変化率を計算してwに代入する
2. 40%以上上昇している日付のデータを抜き出す。同時に当該月のCLI1ヶ月デルタをcbind()する。二十九番目のエントリはCLIがまだ発表されていないため除去する。
3. 当該月の月次データと6ヶ月後のデータを比較して変化率を計算する。

w <- VIX/lag(VIX,2)
w <- cbind(w[w[,4] > 1.4][-29],   delta=as.vector(diff(cli_xts$oecd)[substr(index(w[w[,4] > 1.4]),1,7)]) )

         VIX.Open VIX.High  VIX.Low VIX.Close VIX.Volume VIX.Adjusted    delta

2007-02-27 1.164265 1.776636 1.167954  1.730624        NaN     1.730624  0.11270

2008-09-29 1.049162 1.375391 1.137750  1.423522        NaN     1.423522 -0.83323

2010-01-22 1.203133 1.422549 1.207701  1.461991        NaN     1.461991  0.29017

2010-05-07 1.261941 1.547925 1.335158  1.643918        NaN     1.643918  0.01840

2011-08-08 1.501832 1.496726 1.451666  1.516109        NaN     1.516109 -0.26765

2011-11-01 1.384704 1.442352 1.385843  1.417448        NaN     1.417448 -0.02283

　　　　＜SKIP> 

to.monthly(GSPC)[substr(mondate(index(w[w[,7] > 0]))+6,1,7)][,4] /as.vector(to.monthly(GSPC)[substr(index(w[w[,7] > 0]),1,7)][,4])[-11]

        GSPC.Close

 8 2007   1.047746

 7 2010   1.025822

11 2010   1.083660

10 2013   1.099507

 7 2014   1.083070

12 2016   1.066689

 3 2017   1.089680

11 2017   1.097761

 2 2018   1.097983

12 2020   1.211522

平均は9.03%。

VIX TICK

original is here.

• ファンドストラットのアナリスト、トム・リーは、滅多に見られない2つのシグナルが揃ったことで、強気相場をもたらすだろうと述べている。
• 市場の恐怖指数である「VIX」は2日間で40％も急上昇し、「NYSE Tick Index」は2021年の最低水準まで急落した。
• 過去のデータによると、VIXが急上昇すると「S&P500指数」も数カ月にわたって上昇する傾向があるとリーは言う。

ファンドストラット（Fundstrat）のトップアナリスト、トム・リー（Tom Lee）によると、株式市場の不安感を表す2つのシグナルの最近の動きは、市場に大規模な利益をもたらすものだという。

5月12日朝に公開したリポートでリーは、めったに起こらない2つのイベントが2021年5月11日に発生したことについて詳細を記し、それらは強気相場になるシグナルであることを説明した。

1つ目は、「恐怖指数」と呼ばれるVIX指数が、10日と11日の2日間で40％も急騰したことだ。リーによると、このようなことは1990年以降、20回しか起きていない。

2つ目は、ニューヨーク証券取引所のティック・インデックス（NYSE Tick Index：アップティック銘柄数からダウンティック銘柄数を引いた値を毎秒計測した指標）が、11日には取引開始直後に多くの売りが発生したことで史上最低となるマイナス2069まで急落したこと。これまでにマイナス1800を割り込んだのはわずか10回だけだという。

リーは、これらの出来事は市場のパニックを示していることから、強気相場となるシグナルとみなすことができると述べている。このパニックは、投資家のスタンレー・ドラッケンミラー（Stanley Druckenmiller）の連邦準備制度理事会に関する警告や、マージンコール、あるいは単に「相場の下落」に関連している可能性があるという。

「多くの投資家は、5月11日のNYSE Tick Indexの急落やVIXの急上昇をネガティブなサインと見るかもしれないが、意外にもこれらは強気のシグナルだ」とリーは言う。

「まず、強気相場は『エスカレーターに乗って、エレベーターで落ちる』ということを覚えておいてほしい。つまり、強気相場では、株価は着実に上昇して、その後、急落する。従って、VIXが急上昇し、NYSE Tick Indexが大幅にマイナスになるのはポジティブであると読むことができる」

また、1990年以降、景気後退期を除き、VIXが40％急上昇した後の6カ月間にS&P500は平均10％のリターンを記録していると、リーは付け加えた。市場が景気後退期に突入しない限り、VIXがこれほど大きく急上昇するのは「単なるパニック・リセット」だとリーは言う。

NYSE Tick Indexがマイナス1800を下回った場合、S&P500はその後の6カ月間で平均22%のリターンを記録している。

これは株価が急騰するための絶好の状況であり、プルバック（トレンドとは逆方向の値動き）するまでにS&P500は6％近く跳ね上がって4400に達する可能性があるとリーは述べている。

「結論として、我々はVIXの急上昇とTick Indexの急落をキャピチュレーション（弱気相場での投げ売り）によるものだと見ている。そして投資家がテクノロジー分野からエピセンター（パンデミックの影響を最も強く受けた産業）の銘柄に関心を移していることを意味すると考える」とリーは述べ、旅行、飲食業、ホスピタリティといった産業の回復に連動する銘柄を集めたリストを紹介した。

HiraKakuPro-W3 scale_fill_hue tidyr gather 日本語 行列 matrix axis.ticks.x axis.text.x How to erase x-axis lable X軸のラベルを消すには 横並び 棒グラフ

 

1. 都道府県別データから指定された期間の新規陽性者データを抜き出す。
2. 抜き出したデータをベクターに変換し、都道府県の人口で割り人口あたりの新規陽性者データを算出する。
3. 算出したデータを行列、さらにdata frame に変換する。
4. 3. をtidyr::gather　を使用してggplot 用に変換する。
5. X軸テキスト消去の参考にしたのはこちら。

len <- 90

target <- c(1,13,27,40,47)

data <- mdf

# wdf <- ( ((mdf[,-48] %>% last(.,len) %>% t() %>% as.vector()) /rep(as.vector(pref_pop[,1]) ,len) %>% matrix(.,nrow=47) %>% t() %>% data.frame() )%>% cbind(.,t=last(mdf$t,len)) ) <- BUG

# wdf <-  ((mdf[,-48] %>% last(.,len) %>% t() %>% as.vector()) /rep(as.vector(pref_pop[,1]) ,len) %>% matrix(.,nrow=47)) %>% t() %>% data.frame() %>% cbind(.,t=last(mdf$t,len))

wdf <- ((data[,-48] %>% last(.,len) %>% t() %>% as.vector()) /rep(as.vector(pref_pop[,1]) ,len) %>% matrix(.,nrow=47)) %>% t() %>% data.frame() %>% cbind(.,t=last(data$t,len))

colnames(wdf)[-48] <- pref_en

# df <- (wdf %>% tidyr::gather(reg_name,value,-t))

df <- (wdf %>% tidyr::gather(reg_name,value,target))

p <- ggplot(df,aes(x=t, y=value,fill=reg_name)) 

# p <- p +scale_fill_brewer(palette="Accent")

# p <- p+geom_bar(stat="identity",width=1,position = "fill")

p <- p+geom_bar(stat="identity",width=1,position = "dodge")

# p <- p + geom_histogram(bins=len,position = "fill", alpha = 0.9)

p <- p + theme_gray (base_family = "HiraKakuPro-W3")

p <- p + scale_fill_hue(name="都道府県",labels=pref_jp[target])

p <- p + theme(panel.background = element_rect(fill = "grey90",

                                               colour = "lightblue"))

plot(p)

wdf[,-48] %>% apply(.,2,sum)

df <- wdf[,-48] %>% apply(.,2,sum)

df <- data.frame(df)

df <- cbind(df,region=rownames(df))

p <- ggplot(df, aes(x = region, y = df, fill = region))

p <- p + geom_bar(stat = "identity")

p <- p + theme_gray (base_family = "HiraKakuPro-W3")

# p <- p + theme(axis.ticks.x=element_line(size=8))

p <- p + theme(axis.ticks.x=element_blank())

# p <- p + theme(axis.text.x=element_blank())

# p <- p + theme(axis.text.x=element_line(size=8)) # NG

p <- p + ylab("人口千人あたり") + xlab("")

p <- p + scale_fill_hue(name="都道府県",labels=pref_jp)

p <- p + scale_x_discrete(label=substr(pref_jp,1,1))

p <- p+theme(legend.position = 'none')    # legend terminate 凡例　消去

p <- p + theme(axis.text.x = element_text(angle = 90, hjust = 1))  # x軸　縦書き

plot(p)

"p <- p + theme(axis.text.x = element_text(angle = 90, hjust = 1))"でラベルを横倒し縦書きにできる。

横並び棒グラフ dodge tidyr gather 三指数

 
> last(dmdf,3)
    01Hokkaido 02Aomori 03Iwate 04Miyagi 05Akita 06Yamagata 07Fukushima 08Ibaraki 09Tochigi 10Gunma 11Saitama 12Chiba 13Tokyo 14Kanagawa
477          4        0       0        1       0          0           1         0         1       2         1       7       6          6
478          3        2       1        0       0          0           0         0         0       0         1       5       6          2
479          7        0       1        2       0          1           1         0         0       0         2       1       3          4
    15Niigata 16Toyama 17Ishikawa 18Fukui 19Yamanashi 20Nagano 21Gifu 22Shizuoka 23Aichi 24Mie 25Shiga 26Kyoto 27Osaka 28Hyogo 29Nara
477         0        1          1       0           0        2      1          1       3     1       3       0      50      39      4
478         0        0          4       0           0        0      0          0       2     0       0       2      41       6      0
479         0        0          1       0           0        0      0          0       5     0       0       0      19       8      0
    30Wakayama 31Tottori 32Shimane 33Okayama 34Hiroshima 35Yamaguchi 36Tokushima 37Kagawa 38Ehime 39Kochi 40Fukuoka 41Saga 42Nagasaki
477          0         0         0         3           0           0           1        0       3       0         4      0          0
478          1         0         0         4           1           0           2        0       1       0         1      0          1
479          0         0         0         2           0           2           1        0       1       0         3      0          0
    43Kumamoto 44Oita 45Miyazaki 46Kagoshima 47Okinawa          t
477          1      0          0           0         1 2021-05-07
478          0      0          0           0         0 2021-05-08
479          0      0          0           0         0 2021-05-09

> head(w)

    tokyo osaka hyogo          t

400    11     2     1 2021-02-19

401    27     4     2 2021-02-20

402    17     1     0 2021-02-21

403     9     3     1 2021-02-22

404    11     5     3 2021-02-23

405    17     4     7 2021-02-24

> dplyr::filter(df,t > as.Date("2021-05-07"))

           t variable value

1 2021-05-08    tokyo     6

2 2021-05-09    tokyo     3

3 2021-05-08    osaka    41

4 2021-05-09    osaka    19

5 2021-05-08    hyogo     6

6 2021-05-09    hyogo     8

w <- data.frame(tokyo=dmdf[,13],osaka=dmdf[,27],hyogo=dmdf[,28],t=dmdf$t)

w <- last(w,80)

df <-w  %>% tidyr::gather(variable,value,-t)  #exclude t to preserve time stamp or use "df <-w  %>% tidyr::gather(variable,value,1:3)"

# df

p <- ggplot(df,aes(x=t, y=value, color=variable,fill=variable)) 

# p <- p+geom_histogram(stat = "identity",position = "stack")

p <- p+geom_bar(stat="identity",width=1,position = "dodge")

plot(p)

# end here

# if "df <-w  %>% tidyr::gather(variable,value)  #exclude t to preserve time stamp"

# 警告メッセージ: 

# attributes are not identical across measure variables;

# they will be dropped 

# see w[1:3,] contents are numeric  and w$t is Date.

w <- data.frame(tokyo=dmdf[,13],osaka=dmdf[,27],hyogo=dmdf[,28],t=dmdf$t)

w <- last(w,80)

df <-w  %>% tidyr::gather(variable,value,-t) #exclude t to preserve time stamp or use "df <-w  %>% tidyr::gather(variable,value,1:3)"

# df

p <- ggplot(df,aes(x=t, y=value,fill=variable)) 

p <- p +scale_fill_brewer(palette="Accent")

p <- p+geom_bar(stat="identity",width=1,position = "dodge")

p <- p + theme(panel.background = element_rect(fill = "grey60",

                                               colour = "lightblue"))

plot(p)

len <- 20

w <- data.frame(spx=as.vector(last(weeklyReturn(GSPC),len)),ndx=as.vector(last(weeklyReturn(NDX),len)),dji= as.vector(last(weeklyReturn(DJI),len))    ,t=index(last(weeklyReturn(GSPC),len)))

df <-w  %>% tidyr::gather(index,weeklyreturn,-t)

df$t[len*seq(1,3,1)] <- df$t[dim(df)[1]-1]+7  # adjust each index's last entry. 3 came from gspc, ndx and di.

for(i in seq(1,len*3,1)){if((length(seq(as.Date("1970-01-05"),as.Date(df$t[i]),by='days'))%%7) != 5){df$t[i] <- df$t[i]+5-length(seq(as.Date("1970-01-05"),as.Date(df$t[i]),by='days'))%%7 }} # for the case national holiday distort date.

p <- ggplot(df,aes(x=t, y=weeklyreturn, color=index,fill=index))

p <- p + xlab("") + ylab("週間収益率")

# p <- p + geom_point(aes(y=case_per_capita,size=sign,color=r),alpha=1)

# p <- p+annotate("text",label=pref_db[,1],x=df[,2], y=df[,1]+0.1,colour='black',family = "HiraKakuProN-W3",size=3)

p <- p + theme_gray (base_family = "HiraKakuPro-W3")

p <- p + scale_color_brewer(name="指数",labels=c("ダウ30種","ナスダック","S&P500"),palette="Accent")

p <- p + scale_fill_brewer(name="指数",labels=c("ダウ30種","ナスダック","S&P500"),palette="Accent")

p <- p+geom_bar(stat="identity",width=7,position = "dodge")

plot(p)

名目GDP四半期伸び率 vs. CLI Delta Nominal GDP quater basis legend title #spline #gdp

 

名目GDP四半期伸び率　vs.　CLI Delta Nominal GDP quater basis を対照プロットする。

period <- "2001::2021-06"  # end period month should be march,june,september or december.

w <- (GDPC1/lag(GDPC1))[period] - 1

result <- lm(as.vector(diff(apply.quarterly(cli_xts$oecd,mean))[period]) ~ w)

df <- data.frame(delta=as.vector(diff(apply.quarterly(cli_xts$oecd,mean))[period]) ,gdp=as.vector(w)

                 ,spx= as.vector(quarterlyReturn(GSPC)[period])  )

p <- ggplot(df, aes(y=delta,x=gdp))

p <- p + theme_gray (base_family = "HiraKakuPro-W3")

p <- p + xlab("GDP四半期伸び率") + ylab("CLI delta")

p <- p + geom_point(alpha=1,aes(color=spx))

p <- p + scale_color_gradient(low = "red", high = "green")

p <- p + geom_smooth(method = "lm",se=F,size=0.5)

p <- p + geom_vline(xintercept =(-1*result$coefficients[1] / result$coefficients[2]),

                    size=0.5,linetype=2,colour="red",alpha=0.5)

p <- p + geom_hline(yintercept = last(as.vector(diff(apply.quarterly(cli_xts$oecd,mean))[period])),

                    size=0.5,linetype=2,colour="green",alpha=0.5)

p <- p + geom_vline(xintercept = last(w),

                    size=0.5,linetype=2,colour="green",alpha=0.5)

p <- p+annotate("text",label=as.character(round(-1*result$coefficients[1] / result$coefficients[2],4)),x=(-1*result$coefficients[1] / result$coefficients[2]), y=-5.1,colour='red')

p <- p+annotate("text",label=as.character(round(last(w),4)),x=last(w), y=-5.1,colour='green')

p <- p +  labs(color="S&P500\n四半期\n収益率")

plot(p)

summary(result)

spline を使用して補完の上月次GDPを算出その上でグラフを作成する。

period <- "2015::2021-09"  # end period month should be march,june,september or december.

w <- spline(GDPC1[period],xmin=1/3,xmax=length(GDPC1[period])+1/3,n=3*length(GDPC1[period])+1,method='natural')$y

# w <- w/lag(w) -1

w <- w[2:length(w)]/w[1:(length(w)-1)] - 1

# w <- (GDPC1/lag(GDPC1))[period] - 1

# result <- lm(as.vector(diff(cli_xts$oecd)[period]) ~ w)

result <- lm(as.vector(diff(cli_xts$oecd)[period]) ~ w)

df <- data.frame(delta=as.vector(diff((cli_xts$oecd))[period]) ,gdp=as.vector(w)

                 ,spx= as.vector(monthlyReturn(GSPC)[period])  )

p <- ggplot(df, aes(y=delta,x=gdp))

p <- p + theme_gray (base_family = "HiraKakuPro-W3")

p <- p + xlab("GDP補正月間伸び率") + ylab("CLI delta")

p <- p + geom_point(alpha=1,aes(color=spx))

p <- p + scale_color_gradient(low = "red", high = "green")

p <- p + geom_smooth(method = "lm",se=F,size=0.5)

p <- p + geom_vline(xintercept =(-1*result$coefficients[1] / result$coefficients[2]),

                    size=0.5,linetype=2,colour="red",alpha=0.5)

p <- p + geom_hline(yintercept = last(as.vector(diff((cli_xts$oecd))[period])),

                    size=0.5,linetype=2,colour="green",alpha=0.5)

p <- p + geom_vline(xintercept = last(w),

                    size=0.5,linetype=2,colour="green",alpha=0.5)

p <- p+annotate("text",label=as.character(round(-1*result$coefficients[1] / result$coefficients[2],4)),x=(-1*result$coefficients[1] / result$coefficients[2]), y=-5.1,colour='red')

p <- p+annotate("text",label=as.character(round(last(w),4)),x=last(w), y=-5.1,colour='green')

p <- p +  labs(color="S&P500\n月間\n収益率")

plot(p)

summary(result)

> summary(result)

Call:

lm(formula = as.vector(diff(apply.quarterly(cli_xts$oecd, mean))[period]) ~ w)

Residuals:

     Min       1Q   Median       3Q      Max 

-1.44728 -0.33122  0.01372  0.19903  2.09477 

Coefficients:

            Estimate Std. Error t value Pr(>|t|)    

(Intercept) -0.45260    0.06811  -6.645 3.53e-09 ***

w           47.61859    3.71852  12.806  < 2e-16 ***

---

Signif. codes:  0 '***' 0.001 '**' 0.01 '*' 0.05 '.' 0.1 ' ' 1

Residual standard error: 0.5276 on 79 degrees of freedom

Multiple R-squared:  0.6749, Adjusted R-squared:  0.6708 

F-statistic:   164 on 1 and 79 DF,  p-value: < 2.2e-16

EPS 2021APR27

 

MacBook-Pro-16:~/Downloads$ cat eps.txt 

12/31/2022 $54.64 $50.47 20.39 21.88 $202.75 $188.97

9/30/2022 $52.43 $49.07 21.08 22.63 $196.14 $182.75

6/30/2022 $48.86 $45.76 21.84 23.43 $189.30 $176.48

3/31/2022 $46.82 $43.67 22.64 24.32 $182.63 $170.06

12/31/2021 $48.03 $44.25 23.22 24.79 $178.09 $166.77

9/30/2021 $45.59 $42.80 24.58 26.86   $168.24 $153.96

6/30/2021 $42.19 $39.33 25.76 28.69   $160.55 $144.14

3/31/2021 (25.4%) 3972.89 $42.28 $40.39 28.49 33.72 $145.15 $122.64

12/31/2020 3756.07 $38.18 $31.44 30.69 39.90   $122.37 $94.13

9/30/2020 3363.00 $37.90 $32.98 27.26 34.24   $123.37 $98.22

6/30/2020 3100.29 $26.79 $17.83 24.75 31.24   $125.28 $99.23

3/31/2020 2584.59 $19.50 $11.88 18.64 22.22   $138.63 $116.33

12/31/2019 3230.78 $39.18 $35.53 20.56 23.16   $157.12 $139.47

9/30/2019  2976.74 $39.81 $33.99 19.46 22.40   $152.97 $132.90

6/30/2019 2941.76 $40.14 $34.93 19.04 21.75   $154.54 $135.27

3/31/2019 2834.40 $37.99 $35.02 18.52 21.09   $153.05 $134.39

MacBook-Pro-16:~/Downloads$  tac eps.txt | awk '{gsub("\\$","",$NF);print "eps_year_xts[\"2019::\"]["NR"] <- "$NF}'
eps_year_xts["2019::"][1] <- 134.39
eps_year_xts["2019::"][2] <- 135.27
eps_year_xts["2019::"][3] <- 132.90
eps_year_xts["2019::"][4] <- 139.47
eps_year_xts["2019::"][5] <- 116.33
eps_year_xts["2019::"][6] <- 99.23
eps_year_xts["2019::"][7] <- 98.22
eps_year_xts["2019::"][8] <- 94.13
eps_year_xts["2019::"][9] <- 122.64
eps_year_xts["2019::"][10] <- 144.14
eps_year_xts["2019::"][11] <- 153.96
eps_year_xts["2019::"][12] <- 166.77
eps_year_xts["2019::"][13] <- 170.06
eps_year_xts["2019::"][14] <- 176.48
eps_year_xts["2019::"][15] <- 182.75
eps_year_xts["2019::"][16] <- 188.97

> eps_year_xts["2020::"]

             [,1]

2020-01-01 116.33

2020-04-01  99.23

2020-07-01  98.22

2020-10-01  91.15

2021-01-01 114.36

2021-04-01 133.35

2021-07-01 141.08

2021-10-01 155.56

> eps_year_xts <- append(eps_year_xts,as.xts(rep(0,4),seq(as.Date("2022-01-01"),as.Date("2022-10-01"),by='quarters')))

Create your own discrete scale Source: R/scale-manual.r, R/zxx.r

original is here.

Create your own discrete scaleSource: R/scale-manual.r, R/zxx.r

These functions allow you to specify your own set of mappings from levels in the data to aesthetic values.

• scale_colour_manual(..., values, aesthetics = "colour", breaks = waiver())
• scale_fill_manual(..., values, aesthetics = "fill", breaks = waiver())
• scale_size_manual(..., values, breaks = waiver())
• scale_shape_manual(..., values, breaks = waiver())
• scale_linetype_manual(..., values, breaks = waiver())
• scale_alpha_manual(..., values, breaks = waiver())
• scale_discrete_manual(aesthetics, ..., values, breaks = waiver())

Arguments passed on to discrete_scale

• palette A palette function that when called with a single integer argument (the number of levels in the scale) returns the values that they should take (e.g., scales::hue_pal()).
• limits One of:
• NULL to use the default scale values
• A character vector that defines possible values of the scale and their order
• A function that accepts the existing (automatic) values and returns new ones
• drop Should unused factor levels be omitted from the scale? The default, TRUE, uses the levels that appear in the data; FALSE uses all the levels in the factor.
• na.translate  Unlike continuous scales, discrete scales can easily show missing values, and do so by default. If you want to remove missing values from a discrete scale, specify na.translate = FALSE.
• na.value  If na.translate = TRUE, what aesthetic value should the missing values be displayed as? Does not apply to position scales where NA is always placed at the far right.
• scale_name  The name of the scale that should be used for error messages associated with this scale.
• name The name of the scale. Used as the axis or legend title. If waiver(), the default, the name of the scale is taken from the first mapping used for that aesthetic. If NULL, the legend title will be omitted.
• labels 
• One of:
• NULL for no labels
• waiver() for the default labels computed by the transformation object
• A character vector giving labels (must be same length as breaks)
• A function that takes the breaks as input and returns labels as output
• guide A function used to create a guide or its name. See guides() for more information.
• super The super class to use for the constructed scale
• values a set of aesthetic values to map data values to. The values will be matched in order (usually alphabetical) with the limits of the scale, or with breaks if provided. If this is a named vector, then the values will be matched based on the names instead. Data values that don't match will be given na.value.
• aesthetics Character string or vector of character strings listing the name(s) of the aesthetic(s) that this scale works with. This can be useful, for example, to apply colour settings to the colour and fill aesthetics at the same time, via aesthetics = c("colour", "fill").
• breaks
• One of:
• NULL for no breaks
• waiver() for the default breaks (the scale limits)
• A character vector of breaks
• A function that takes the limits as input and returns breaks as output

Details

The functions scale_colour_manual(), scale_fill_manual(), scale_size_manual(), etc. work on the aesthetics specified in the scale name: colour, fill, size, etc. However, the functions scale_colour_manual() and scale_fill_manual() also have an optional aesthetics argument that can be used to define both colour and fill aesthetic mappings via a single function call (see examples). The function scale_discrete_manual() is a generic scale that can work with any aesthetic or set of aesthetics provided via the aesthetics argument.

Color Blindness

Many color palettes derived from RGB combinations (like the "rainbow" color palette) are not suitable to support all viewers, especially those with color vision deficiencies. Using viridis type, which is perceptually uniform in both colour and black-and-white display is an easy option to ensure good perceptive properties of your visulizations. 

The colorspace package offers functionalitiesto generate color palettes with good perceptive properties,to analyse a given color palette, like emulating color blindness,and to modify a given color palette for better perceptivity.

Examples

p <- ggplot(mtcars, aes(mpg, wt)) +
  geom_point(aes(colour = factor(cyl)))
p + scale_colour_manual(values = c("red", "blue", "green"))

# It's recommended to use a named vector
cols <- c("8" = "red", "4" = "blue", "6" = "darkgreen", "10" = "orange")
p + scale_colour_manual(values = cols)

# You can set color and fill aesthetics at the same time
ggplot(
  mtcars,
  aes(mpg, wt, colour = factor(cyl), fill = factor(cyl))
) +
  geom_point(shape = 21, alpha = 0.5, size = 2) +
  scale_colour_manual(
    values = cols,
    aesthetics = c("colour", "fill")
  )

# As with other scales you can use breaks to control the appearance
# of the legend.
p + scale_colour_manual(values = cols)
p + scale_colour_manual(
  values = cols,
  breaks = c("4", "6", "8"),
  labels = c("four", "six", "eight")
)

# And limits to control the possible values of the scale
p + scale_colour_manual(values = cols, limits = c("4", "8"))
#> Warning: Removed 7 rows containing missing values (geom_point).
p + scale_colour_manual(values = cols, limits = c("4", "6", "8", "10"))

palette color 色の定義 scale_fill_manual manal scale マニュアルスケール 色見本

1. define gradient private palette and pick up 5 colors. 

my_palette <- colorRampPalette(c("#FF0000","#FFFF00","#00FF00","#00FFFF","#0000FF"))
plot_col <- my_palette(5)[5:1]

2.pick up 5 colors from the standard palette "Spectral".

RColorBrewer::brewer.pal(5,"Spectral")[5:1]

3.display sample

barplot(rep(1,15), col=my_palette(15), axes=FALSE)

barplot(rep(1,11), col=RColorBrewer::brewer.pal(11,"Spectral")[11:1], axes=FALSE)

*note that spectral max color num is 11.

3. define private palette

my_palette <- colorRampPalette(c("#FF0000","#FFFF00","#00FF00","#00FFFF","#0000FF"))

# create 47 colors from my_palette.

g <- g + scale_fill_manual(name='regions',values=my_palette(47),labels=pref_jp)

# can't use scale_fill_hue with 'values=' parameter.

atan plot.default pch

 

> atan2(diff(cli_xts$oecd),diff(diff(cli_xts$oecd))) %>% last(.,)

               oecd

2021-03-01 1.495797

adjust to the date of the last available data.

v <- atan2(diff(cli_xts$oecd),diff(diff(cli_xts$oecd))) %>% last(.,240)
w <- monthlyReturn(GSPC)["::2021-03"] %>% last(.,240) # update if necessary.
par(bg="grey",fg="white")

plot.default(v,w,type='p')

tmp <- par('usr')

plot.new()

plot.default(v,w,xlim=c( tmp[1],tmp[2]), ylim=c(tmp[3], tmp[4]),type='p')
abline(v=pi/2)
abline(v=0)
par(new=T)
i <- 12
plot.default(last(v,i),last(w,i),xlim=c( tmp[1],tmp[2]), ylim=c(tmp[3], tmp[4]),type='b',pch='+',col='brown')
for(k in seq(1,9,1)){
  j <- k %% 8 + 1
  par(new=T)
  print(i)
  print(j)
  plot.default(last(v,i)[k],last(w,i)[k],xlim=c( tmp[1],tmp[2]), ylim=c(tmp[3], tmp[4]),type='p',pch=as.character(k),col=j)
}

tidyverse tidyr dplyr detach search searchpath library library(help= )

 

> search()   

> searchpaths()    # インストール場所の絶対パスを得る

# あるライブラリ中のオブジェクトの一覧を見る　library(help=パッケージ名) 

# もちろんそのライブラリが既にインストールされている必要があります。

> library(gstat)       # ライブラリ gstat をロード

> library(help=gstat)　# gstat 中のオブジェクト（関数、データセット）の一覧を得る

> library(tidyverse)
─ Attaching packages ─────────────────────────────────────────────────── tidyverse 1.3.0 ─
✓ tibble  3.1.0     ✓ dplyr   1.0.5
✓ tidyr   1.1.3     ✓ stringr 1.4.0
✓ readr   1.4.0     ✓ forcats 0.5.1
✓ purrr   0.3.4     
─ Conflicts ───────────────────────────────────────────────────── tidyverse_conflicts() ─
x stringr::boundary() masks strucchange::boundary()
x dplyr::filter()     masks stats::filter()
x dplyr::first()      masks xts::first()
x dplyr::lag()        masks stats::lag()
x dplyr::last()       masks xts::last()
x dplyr::select()     masks MASS::select()

> data(mtcars)
> mtcars <- as_tibble(mtcars, rownames = "model") %>% mutate(cyl = as.character(cyl))
> g <- ggplot(mtcars, aes(x = mpg, y = wt, color = cyl)) +
+     geom_text(aes(label = model), family = family_sans, fontface = "plain") +
+     labs(x =paste(family_serif, "ボールドを使用"), y = paste(family_serif, "イタリックを使用"),
+          title = paste(family_serif, "ボールドイタリックを使用")) +
+     annotate("text", x = 10, y = 2, label = paste(family_sans, "標準書体を使用"), hjust = 0) +
+     theme(
+         text = element_text(family = family_serif, face = "plain"),
+         title = element_text(face = "bold.italic"),
+         axis.title = element_text(face = "italic"),
+         axis.title.x = element_text(face = "bold")
+     )
> g
Error in grid.Call(C_textBounds, as.graphicsAnnot(x$label), x$x, x$y,  : 
  polygon edge not found
In addition: There were 50 or more warnings (use warnings() to see the first 50)
> g <- ggplot(mtcars, aes(x = mpg, y = wt, color = cyl)) +
+     geom_text(aes(label = model), family = family_sans, fontface = "plain") +
+     labs(x =paste(family_serif, "ボールドを使用"), y = paste(family_serif, "イタリックを使用"),
+          title = paste(family_serif, "ボールドイタリックを使用")) +
+     annotate("text", x = 10, y = 2, label = paste(family_sans, "標準書体を使用"), hjust = 0) +
+     theme(
+         text = element_text(family = family_serif, face = "plain"),
+         title = element_text(face = "bold.italic"),
+         axis.title = element_text(face = "italic"),
+         axis.title.x = element_text(face = "bold")
+     )
> g
Error in grid.Call(C_textBounds, as.graphicsAnnot(x$label), x$x, x$y,  : 
  polygon edge not found
In addition: Warning message:
In grid.Call(C_textBounds, as.graphicsAnnot(x$label), x$x, x$y,  :
  no font could be found for family "Hiragino Mincho ProN"
> last(dmdf[,13],10)   # blocked by dplyr
Error in order(order_by)[[n]] : subscript out of bounds
> detach("package:tidyverse", unload=TRUE)
> last(dmdf[,13],10)
Error in order(order_by)[[n]] : subscript out of bounds
> search()
 [1] ".GlobalEnv"           "package:forcats"      "package:stringr"      "package:dplyr"        "package:purrr"        "package:readr"       
 [7] "package:tidyr"        "package:tibble"       "package:RColorBrewer" "package:ggplot2"      "tools:rstudio"        "package:datasets"    
[13] "package:beepr"        "package:forecast"     "package:mondate"      "package:vars"         "package:lmtest"       "package:urca"        
[19] "package:strucchange"  "package:sandwich"     "package:MASS"         "package:utils"        "package:graphics"     "package:grDevices"   
[25] "package:quantmod"     "package:TTR"          "package:xts"          "package:zoo"          "package:stats"        "package:methods"     
[31] "Autoloads"            "package:base"        
> detach("package:dplyr", unload=TRUE)
Warning message:
‘dplyr’ namespace cannot be unloaded:
  namespace ‘dplyr’ is imported by ‘dbplyr’, ‘broom’, ‘tidyr’ so cannot be unloaded 
> detach("package:tidyr", unload=TRUE)
Warning message:
‘tidyr’ namespace cannot be unloaded:
  namespace ‘tidyr’ is imported by ‘broom’ so cannot be unloaded 
> detach("package:broom", unload=TRUE)
Error in detach("package:broom", unload = TRUE) : invalid 'name' argument
> detach("package:tidyr", unload=TRUE)
Error in detach("package:tidyr", unload = TRUE) : invalid 'name' argument
> detach("package:dplyr", unload=TRUE)
Error in detach("package:dplyr", unload = TRUE) : invalid 'name' argument
> last(dmdf[,13],10)
 [1]  7 18  6  7 15 16 20 12 10 23