├── M-test
    ├── OMDEX.m
    ├── contraction.m
    ├── flow_utility.m
    ├── gen_mileage_trans.m
    ├── gen_price_trans.m
    ├── generate_data.m
    ├── logLH.m
    ├── logLH_stat.m
    ├── logLH_stat_test.m
    ├── mat_ij.m
    ├── mat_ij_test.m
    ├── matlab.mat
    ├── start.m
    └── test.m
└── R-Test
    ├── .RData
    ├── .Rhistory
    ├── New Text Document.xlsx
    ├── agentDynamic.R
    └── plot.r


/M-test/OMDEX.m:
--------------------------------------------------------------------------------
https://raw.githubusercontent.com/GreatHub1204/Data-analysis-by-the-R-Program/74e45f3dc6d86d5b882c901772b7836739405d1b/M-test/OMDEX.m


--------------------------------------------------------------------------------
/M-test/contraction.m:
--------------------------------------------------------------------------------
 1 | function EV = contraction(theta, beta, trans_mat, state_df, num_states, num_choice, Euler_const)
 2 |     U = flow_utility(theta, state_df);
 3 |     EV_old = zeros(num_states, num_choice);
 4 |     diff=1000;
 5 |     tol_level=1e-10;
 6 |     while(diff>tol_level)      
 7 |         EV_not_buy = Euler_const +trans_mat.not_buy * log(sum(exp(U + beta.*EV_old),2));
 8 |         EV_buy = Euler_const+trans_mat.buy * log(sum(exp(U + beta.*EV_old),2));
 9 |         EV_new = horzcat(EV_not_buy, EV_buy);       
10 |         diff = sum(abs(EV_new - EV_old),"all");        
11 |         EV_old = EV_new;
12 |     end
13 |     EV = EV_old;
14 |     EV = array2table(EV,...
15 |         'VariableNames',{'EV_not_buy','EV_buy'});
16 | end


--------------------------------------------------------------------------------
/M-test/flow_utility.m:
--------------------------------------------------------------------------------
1 | function U = flow_utility(theta, state_df)
2 |     theta_c = theta(1);
3 |     
4 |     theta_p = theta(2);
5 |     U_not_buy = - theta_c.*state_df.mileage;
6 |     U_boy = - theta_p.*state_df.price;
7 |     U = [U_not_buy U_boy];
8 | end
9 | 


--------------------------------------------------------------------------------
/M-test/gen_mileage_trans.m:
--------------------------------------------------------------------------------
 1 | function output = gen_mileage_trans(kappa, num_mileage_states, num_choice)
 2 |     kappa_1 = kappa(1);
 3 |     kappa_2 = kappa(2);
 4 | 
 5 | mileage_trans_mat_hat_not_buy = zeros(num_mileage_states, num_mileage_states);
 6 | for i = 1:num_mileage_states
 7 |     for j = 1:num_mileage_states
 8 |         if i == j
 9 |             mileage_trans_mat_hat_not_buy(i, j) = 1 - kappa_1 - kappa_2;
10 |         elseif i == j - 1
11 |             mileage_trans_mat_hat_not_buy(i, j) = kappa_1;
12 |         elseif i == j - 2
13 |             mileage_trans_mat_hat_not_buy(i, j) = kappa_2;
14 |         % elseif i == j + 1
15 |         %     mileage_trans_mat_hat_not_buy(i, j) = 0.00;
16 |         end
17 |     end
18 | end
19 | 
20 | mileage_trans_mat_hat_not_buy(num_mileage_states - 1, num_mileage_states) = kappa_1 + kappa_2;
21 | mileage_trans_mat_hat_not_buy(num_mileage_states, num_mileage_states) = 1;
22 | 
23 | mileage_trans_mat_hat_buy = ones(num_mileage_states, 1) * mileage_trans_mat_hat_not_buy(1, :);
24 | 
25 | output = reshape([mileage_trans_mat_hat_not_buy, mileage_trans_mat_hat_buy], [num_mileage_states, num_mileage_states, num_choice]);
26 | 
27 | end


--------------------------------------------------------------------------------
/M-test/gen_price_trans.m:
--------------------------------------------------------------------------------
1 | function price_trans_mat_hat = gen_price_trans(lambda)
2 |     lambda_11 = 1 - sum(lambda(1:5));
3 |     lambda_22 = 1 - sum(lambda(6:10));
4 |     lambda_33 = 1 - sum(lambda(11:15));
5 |     lambda_44 = 1 - sum(lambda(16:20));
6 |     lambda_55 = 1 - sum(lambda(21:25));
7 |     lambda_66 = 1 - sum(lambda(26:30));
8 |     price_trans_mat_hat = [lambda_11, lambda(1), lambda(2), lambda(3), lambda(4), lambda(5);                           lambda(6), lambda_22, lambda(7), lambda(8), lambda(9), lambda(10);                           lambda(11), lambda(12), lambda_33, lambda(13), lambda(14), lambda(15);                           lambda(16), lambda(17), lambda(18), lambda_44, lambda(19), lambda(20);                           lambda(21), lambda(22), lambda(23), lambda(24), lambda_55, lambda(25);                           lambda(26), lambda(27), lambda(28), lambda(29), lambda(30), lambda_66];
9 | end


--------------------------------------------------------------------------------
/M-test/generate_data.m:
--------------------------------------------------------------------------------
 1 | function df = generate_data(df, V_CS, state_df, price_dist_steady, num_period, trans_mat_cum)    
 2 |   price_dist_steady_cumsum = cumsum(price_dist_steady); 
 3 |   price_id_consumer = 0;
 4 |   exceed_trans_prob_price = true;
 5 |   while exceed_trans_prob_price
 6 |       price_id_consumer = price_id_consumer + 1;
 7 |       if(df.eps_price_state_unif(1) > price_dist_steady_cumsum(price_id_consumer))
 8 |           exceed_trans_prob_price = true;
 9 |       elseif(df.eps_price_state_unif(1) < price_dist_steady_cumsum(price_id_consumer))
10 |           exceed_trans_prob_price = false;
11 |       end
12 |   end
13 |   df.state_id(1) = table2array(state_df(state_df.mileage_id == 1 & state_df.price_id == price_id_consumer, 'state_id')); 
14 | 
15 |   for t = 1:(num_period-1)
16 |     
17 |      % df.state_id(t) = table2array(state_df(state_df.mileage_id == 1 & state_df.price_id == price_id_consumer, 'state_id'));
18 |     
19 |     
20 |     if df.state_id(t) ==0 || isnan(df.state_id(t))
21 |         state_id_today = 1;
22 |     else
23 |         state_id_today = df.state_id(t);        
24 |     end
25 |     
26 |     if table2array(V_CS(state_id_today, 'V_not_buy')) + df.eps_type1_not_buy(t) > table2array(V_CS(state_id_today, 'V_buy')) + df.eps_type1_buy(t)  
27 |       
28 |         df.action(t) = 0;            
29 |         trans_mat_cum_today = trans_mat_cum.not_buy;
30 |         % fprintf('trans_mat_cum_today = %f\n', trans_mat_cum_today);
31 |     else     
32 |         df.action(t) = 1;      
33 |     
34 |         trans_mat_cum_today = trans_mat_cum.buy;
35 |     end      
36 |     state_id_tomorrow = 0;
37 |     exceed_trans_prob = true;
38 |     break_flag = 0;
39 |     while exceed_trans_prob
40 |         state_id_tomorrow = state_id_tomorrow + 1;     
41 |         
42 |         trans_prob = trans_mat_cum_today(state_id_today, state_id_tomorrow);
43 |         exceed_trans_prob = (df.eps_unif(t) > trans_prob);
44 |         if state_id_tomorrow >125
45 |             break_flag = 1;
46 |             break;
47 |         end
48 |     end
49 |     if break_flag ==1
50 |         df.state_id(t+1) = 13;
51 |         break_flag = 0;
52 |     else
53 |         df.state_id(t+1) = state_id_tomorrow;
54 |     end
55 |   end
56 | end


--------------------------------------------------------------------------------
/M-test/logLH.m:
--------------------------------------------------------------------------------
1 | function loglh = logLH(theta, beta, trans_mat, state_df, df, num_states, num_choice, Euler_const)
2 |     EV = contraction(theta, beta, trans_mat, state_df, num_states, num_choice, Euler_const);
3 |     U = flow_utility(theta, state_df);
4 |     V_CS = U + beta.*EV;
5 |     prob_C = table2array(exp(V_CS))./table2array(sum(exp(V_CS),2));
6 |     loglh = sum(log(mat_ij(df.state_id_state_df, df.action, prob_C)));
7 | end


--------------------------------------------------------------------------------
/M-test/logLH_stat.m:
--------------------------------------------------------------------------------
 1 | function lh_value = logLH_stat(theta, state_df, df)
 2 | 
 3 |     U = flow_utility(theta, state_df);
 4 | 
 5 |     prob_C_stat = exp(U) ./ sum(exp(U),2);
 6 |     
 7 |     lh_value =sum(log(mat_ij(df.state_id_state_df, df.action, prob_C_stat)));
 8 | end
 9 | 
10 | 


--------------------------------------------------------------------------------
/M-test/logLH_stat_test.m:
--------------------------------------------------------------------------------
1 | function scalar = logLH_stat_test(theta, state_df, df)
2 |     U = flow_utility(theta, state_df);
3 | 
4 |     prob_C_stat = exp(U)./sum(exp(U),2);
5 |      
6 |     % fprintf('prob_C_stat = %f\n', prob_C_stat);
7 |     scalar = sum(log(mat_ij_test(df.state_id_state_df, df.action+1, prob_C_stat)));
8 |    
9 | end


--------------------------------------------------------------------------------
/M-test/mat_ij.m:
--------------------------------------------------------------------------------
 1 | function matVector = mat_ij(state_id, action, mat)
 2 | 
 3 |     for i=1:length(state_id)
 4 |         vectorize = mat(state_id(i), action(i)+1);
 5 |         if i==1
 6 |             matVector = vectorize;
 7 |         else
 8 |             matVector = horzcat(matVector, vectorize);
 9 |         end
10 |     end
11 | end


--------------------------------------------------------------------------------
/M-test/mat_ij_test.m:
--------------------------------------------------------------------------------
 1 | function vectorize = mat_ij_test(state_id, action, mat)
 2 |     if length(state_id)~=1
 3 |         for i=1:length(state_id)
 4 |             vectorize = mat(state_id(i), action(i));
 5 |             if i==1
 6 |                 matVector = vectorize;
 7 |             else
 8 |                 matVector = horzcat(matVector, vectorize);
 9 |             end
10 |         end
11 |     else
12 |         vectorize = mat(state_id, action+1);
13 |         vectorize = horzcat(vectorize(:));
14 |     end
15 | end


--------------------------------------------------------------------------------
/M-test/matlab.mat:
--------------------------------------------------------------------------------
https://raw.githubusercontent.com/GreatHub1204/Data-analysis-by-the-R-Program/74e45f3dc6d86d5b882c901772b7836739405d1b/M-test/matlab.mat


--------------------------------------------------------------------------------
/M-test/start.m:
--------------------------------------------------------------------------------
  1 | % 2.2 データの生成
  2 | % 2.2.1 パラメータの設定
  3 | 
  4 | % 2.2.1.1 状態変数の作成
  5 | % ## パラメータの設定
  6 | 
  7 | % # 走行距離にかかるtheta_cと車の価格にかかるtheta_p
  8 | load carbig
  9 | % clc
 10 | % clear
 11 | 
 12 | theta_c = 0.004;
 13 | theta_p = 0.003;
 14 | theta_true = [theta_c, theta_p];
 15 | 
 16 | % 時間割引率
 17 | beta = 0.99;
 18 | 
 19 | % オイラー定数
 20 | Euler_const = -psi(1);
 21 | 
 22 | % ## Stateの作成
 23 | num_choice = 2;
 24 | % # 価格の状態変数
 25 | price_states = 2000:100:2500;
 26 | 
 27 | % # 走行距離の状態変数
 28 | mileage_states = 0:5:100;
 29 | % # 価格の状態変数の数
 30 | num_price_states = length(price_states);
 31 | % # 走行距離の状態変数の数
 32 | num_mileage_states = length(mileage_states);
 33 | 
 34 | % # 状態変数は価格と走行距離の状態変数のペア
 35 | % # 従って状態変数の数は価格の状態変数の数と走行距離の状態変数の数の積となる
 36 | num_states = num_price_states * num_mileage_states;
 37 | 
 38 | % # 価格、走行距離の状態変数の組み合わせ(p,m)を1つのデータフレームで表す   
 39 | state_id = (1:num_states)';
 40 | price_id = repmat(1:num_price_states, [1, num_mileage_states]);
 41 | mileage_id = repmat(1:num_mileage_states, [num_price_states, 1]);
 42 | price = repmat(price_states, [1, num_mileage_states])';
 43 | mileage = repmat(mileage_states, [num_price_states, 1]);
 44 | 
 45 | state_df = table(state_id, price_id(:), mileage_id(:), price(:), mileage(:));
 46 | state_df.Properties.VariableNames = {'state_id', 'price_id', 'mileage_id', 'price', 'mileage'};
 47 | 
 48 | tail(state_df, 3)
 49 | 
 50 | % 2.2.1.2 遷移行列の作成
 51 | format short
 52 | 
 53 | % # 走行距離の遷移行列のパラメタを設定し、遷移行列を作成する
 54 | kappa_true = [0.25, 0.05];
 55 | 
 56 | 
 57 | mileage_trans_mat_true = gen_mileage_trans(kappa_true, num_mileage_states, num_choice);
 58 | % # 走行距離の遷移行列の4行4列までを表示
 59 | mileage_trans_mat_true(1:4,1:4,1)
 60 | 
 61 | % # 価格の遷移行列のパラメタを設定し、遷移行列を作成する
 62 | lambda_true = [0.1, 0.2, 0.2, 0.2, 0.2, 0.1, 0.2, 0.2, 0.2, 0.2, 0.1, 0.1, 0.2, 0.2, 0.1, 0.1, 0.1, 0.2, 0.2, 0.1, 0.05, 0.05, 0.1, 0.1, 0.2, 0.05, 0.05, 0.1, 0.1, 0.2];
 63 | price_trans_mat_true = gen_price_trans(lambda_true);
 64 | % # 価格の遷移行列を表示
 65 | price_trans_mat_true
 66 | 
 67 | % # コントロール変数毎の遷移行列を作成
 68 | trans_mat_true = [];
 69 | 
 70 | % # 車を購入しない場合の遷移行列
 71 | trans_mat_true.not_buy = kron(mileage_trans_mat_true(:,:,1), price_trans_mat_true);
 72 | 
 73 | % # 車を購入する場合の遷移行列
 74 | trans_mat_true.buy = kron(mileage_trans_mat_true(:,:,2), price_trans_mat_true);
 75 | % 
 76 | % # 定常状態での価格の分布を計算
 77 | % # 以下を満たすような price_dist_steady を求める
 78 | % # price_dist_steady %*% price_trans_mat == price_dist_steady
 79 | % 
 80 | % # 固有値/固有ベクトルを求める
 81 | % # 固有値が1となる固有ベクトルは1つだけ（1つめ）
 82 | price_trans_eigen = eig(price_trans_mat_true.');
 83 | % # 価格の定常分布を求める
 84 | [V,D] = eig(price_trans_mat_true.');
 85 | 
 86 | price_dist_steady = V(:,1)/sum(V(:,1));
 87 | price_dist_steady
 88 | 
 89 | 
 90 | % 2.2.1.3 効用関数の定義
 91 | % 2.2.1.4 価値関数反復法
 92 | 
 93 | % # EVを求める
 94 | start_time = tic;
 95 | 
 96 | EV_true = contraction(theta_true, beta, trans_mat_true, state_df, num_states, num_choice, Euler_const);
 97 | 
 98 | end_time = tic;
 99 | 
100 | disp('Runtime:')
101 | disp(end_time - start_time)
102 | % # 選択毎の価値関数を定義する
103 | U_true = flow_utility(theta_true, state_df);
104 | V_CS_true = U_true + times(beta,EV_true);
105 | V_CS_true = renamevars(V_CS_true,["EV_not_buy","EV_buy"],["V_not_buy","V_buy"]);
106 | 
107 | V_CS_true
108 | 
109 | % # state(p,m)ごとに、logitで計算される理論上の条件付き購入確率を計算
110 | exp_V_buy = exp(V_CS_true(:, "V_buy"));
111 | exp_V_buy = renamevars(exp_V_buy,["V_buy"],["V1"]);
112 | exp_V_sum = sum(exp(V_CS_true),2);
113 | exp_V_sum = renamevars(exp_V_sum,["sum"],["V1"]);
114 | 
115 | format long
116 | prob_buy = exp_V_buy ./ exp_V_sum;
117 | prob_buy;
118 | prob_buy1 = table2array(prob_buy)
119 | 
120 | trans_mat_true_not_buy = reshape(prob_buy1, [num_price_states, num_mileage_states]);
121 | 
122 | trans_mat_true_not_buy
123 | 
124 | % 2.2.2 シミュレーション
125 | 
126 | % ## サンプルサイズを決める
127 | % 
128 | % # 1000人の消費者が存在
129 | num_consumer = 1000;
130 | % # 50年分の月次データを生成した後、最後の10年のみが観察できるとする
131 | num_period = 12 * 50;
132 | 
133 | num_period_obs = 12*10;
134 | 
135 | num_obs = num_consumer * num_period;
136 | % # 累積分布確率を持つように遷移行列を変換（行方向に足し上げる）
137 | trans_mat_cum = [];
138 | format short
139 | trans_mat_cum.not_buy = cumsum(trans_mat_true.not_buy, 2);
140 | 
141 | trans_mat_cum.buy = cumsum(trans_mat_true.buy, 2);
142 | 
143 | % # 乱数を固定
144 | rng(1)
145 | 
146 | % # 生成するデータの元となるdata.frameを作成
147 | consumer = repmat(1:num_consumer, [num_period, 1]);
148 | period = repmat(1:num_period,[1, num_consumer]);
149 | eps_type1_not_buy = gevrnd(0, 1, 0, num_obs, 1);
150 | eps_type1_buy = gevrnd(0, 1, 0, num_obs, 1);
151 | eps_unif = unifrnd(0, 1, [num_obs 1]);
152 | eps_price_state_unif = unifrnd(0, 1, [num_obs 1]);
153 | state_id = zeros(num_obs, 1);
154 | action = zeros(num_obs, 1);
155 | 
156 | data_gen = table(consumer(:), period(:),eps_type1_not_buy(:), eps_type1_buy(:),  eps_unif(:), eps_price_state_unif(:), state_id, action);
157 | data_gen.Properties.VariableNames = {'consumer', 'period','eps_type1_not_buy', 'eps_type1_buy', 'eps_unif', 'eps_price_state_unif', 'state_id', 'action'};
158 | 
159 | data_gen_groups = splitapply(@ (consumer, period, eps_type1_not_buy, eps_type1_buy, eps_unif, eps_price_state_unif, state_id, action) {table(consumer, period, eps_type1_not_buy, eps_type1_buy, eps_unif, eps_price_state_unif, state_id, action)}, data_gen, findgroups(data_gen.consumer));
160 | results = cell(1, numel(data_gen_groups));
161 | 
162 | for i = 1:numel(data_gen_groups)  
163 |     group = data_gen_groups{i};
164 |     results{i} = generate_data(group, V_CS_true, state_df, price_dist_steady, num_period, trans_mat_cum);
165 |     data_gen_result = vertcat(results{:});
166 | end
167 | 
168 | data_gen_result = data_gen_result(data_gen_result.period > (num_period - num_period_obs), :);
169 | data_gen_result = outerjoin(data_gen_result, state_df, 'Keys', 'state_id');
170 | tail(data_gen_result, 3)
171 | 
172 | clear V_CS_true trans_mat_cum;
173 | 
174 | % 3 記述統計
175 | 
176 | % data_gen_result = data_gen_result(~isnan(data_gen_result.consumer),{'consumer', 'period','eps_type1_not_buy','eps_type1_buy','eps_unif','eps_price_state_unif','state_id_data_gen_result','action','state_id_state_df','price_id','mileage_id','price', 'mileage'});
177 | data_gen_selected = data_gen_result(:, {'price', 'mileage', 'action'});
178 | for i=1:length(data_gen_selected.action)
179 |     if isnan(data_gen_selected.action(i))
180 |         data_gen_selected.action(i) = 0;
181 |     end
182 | end
183 | mean_val = mean(data_gen_selected);
184 | mean_val = reshape(table2array(mean_val), [3,1]);
185 | sd_val = std(data_gen_selected);
186 | sd_val = reshape(table2array(sd_val), [3,1]);
187 | p0_val = min(data_gen_selected);
188 | p0_val = reshape(table2array(p0_val), [3,1]);
189 | p100_val = max(data_gen_selected);
190 | p100_val = reshape(table2array(p100_val), [3,1]);
191 | skim_variable = [{'price'; 'mileage'; 'action'}];
192 | 
193 | 
194 | % # 生成したデータの要約統計
195 | data_gen_table = table( mean_val, sd_val, p0_val, p100_val, ...
196 |                      'VariableNames', {'mean', 'sd', 'p0', 'p100'}, 'RowNames',skim_variable);
197 | data_gen_table
198 | 
199 | table2array(data_gen_table('price',:));
200 | 
201 | figure;
202 | 
203 | histogram(data_gen_selected.price, 6, FaceColor='black');
204 | 
205 | xlabel('price');
206 | ylabel('count');
207 | 
208 | 
209 | 
210 | figure;
211 | 
212 | y = histogram(data_gen_selected.mileage, 21, FaceColor='black');
213 | xlabel('mileage');
214 | ylabel('count');
215 | 
216 | 
217 | figure;
218 | 
219 | grouped_data = varfun(@(x) {numel(x), sum(x)}, data_gen_selected, 'InputVariables', 'action', 'GroupingVariables', 'mileage');
220 | grouped_data.Properties.VariableNames{'GroupCount'} = 'num_state';
221 | grouped_data.Properties.VariableNames{'Fun_action'} = 'sum_action';
222 | grouped_data.sum_action = cell2mat(grouped_data.sum_action(:,1))+cell2mat(grouped_data.sum_action(:,2));
223 | grouped_data.sum_action
224 | grouped_data.prob_buy = (grouped_data.sum_action ./ grouped_data.num_state)-1;
225 | grouped_data.prob_buy
226 | bar(grouped_data.mileage, grouped_data.prob_buy);
227 | xlabel('mileage');
228 | ylabel('prob\_buy');
229 | 
230 | 
231 | figure;
232 | 
233 | grouped_data = varfun(@(x) {numel(x), sum(x)}, data_gen_selected, 'InputVariables', 'action', 'GroupingVariables', 'price');
234 | grouped_data.Properties.VariableNames{'GroupCount'} = 'num_state';
235 | grouped_data.Properties.VariableNames{'Fun_action'} = 'sum_action';
236 | grouped_data.sum_action = cell2mat(grouped_data.sum_action(:,1))+cell2mat(grouped_data.sum_action(:,2))
237 | 
238 | 
239 | grouped_data.prob_buy = (grouped_data.sum_action ./ grouped_data.num_state)-1;
240 | grouped_data.prob_buy
241 | bar(grouped_data.price, grouped_data.prob_buy);
242 | xlabel('price');
243 | ylabel('prob\_buy');
244 | 
245 | figure;
246 | grouped_data = varfun(@(x) {numel(x), sum(x)}, data_gen_result, 'InputVariables', 'action', 'GroupingVariables', {'mileage', 'price'});
247 | 
248 | grouped_data.Properties.VariableNames{'GroupCount'} = 'num_state';
249 | grouped_data.Properties.VariableNames{'Fun_action'} = 'sum_action';
250 | 
251 | grouped_data.sum_action = cell2mat(grouped_data.sum_action(:,1))+cell2mat(grouped_data.sum_action(:,2))
252 | prob_buy_obs_mat = reshape( -((grouped_data.num_state./ grouped_data.sum_action)-1), [num_price_states, num_mileage_states]);
253 | prob_buy_obs_mat
254 | prob_buy_obs_mat = transpose(prob_buy_obs_mat);
255 | 
256 | 
257 | 
258 | x1=price_states;
259 | y1=mileage_states;
260 | z=prob_buy_obs_mat; 
261 | bar3( z (:,:,1)); 
262 | set(gca,'XTickLabel',x1)
263 | set(gca,'YTickLabel',y1)
264 | xlabel('Mileage'); ylabel('Price'); zlabel('Probability');
265 | 
266 | 
267 | 
268 | 
269 | 
270 | data_gen_groups = splitapply(@ (varargin) {table(varargin{1}, varargin{2}, varargin{3}, varargin{4}, varargin{5}, varargin{6}, varargin{7}, varargin{8}, varargin{9}, varargin{10}, varargin{11}, varargin{12},varargin{13})}, data_gen_result, findgroups(data_gen_result.consumer));
271 | 
272 | num = length(data_gen_groups);
273 | for i = 1:num
274 |     group = data_gen_groups{i};
275 |     group.lag_price_id = [NaN; group.Var10(1:end-1)];
276 |     group.lag_mileage_id = [NaN; group.Var11(1:end-1)];
277 |     group.lag_action = [NaN; group.Var8(1:end-1)];
278 |     group.Properties.VariableNames{1} = 'consumer';
279 |     group.Properties.VariableNames{2} = 'period';
280 |     group.Properties.VariableNames{3} = 'eps_type1_not_buy';
281 |     group.Properties.VariableNames{4} = 'eps_type1_buy';
282 |     group.Properties.VariableNames{5} = 'eps_unif';
283 |     group.Properties.VariableNames{6} = 'eps_price_state_unif';
284 |     group.Properties.VariableNames{7} = 'state_id_data_gen_result';
285 |     group.Properties.VariableNames{8} = 'action';
286 |     group.Properties.VariableNames{9} = 'state_id';
287 |     group.Properties.VariableNames{10} = 'price_id';
288 |     group.Properties.VariableNames{11} = 'mileage_id';
289 |     group.Properties.VariableNames{12} = 'price';
290 |     group.Properties.VariableNames{13} = 'mileage';
291 |     if i == 1
292 |         data_consumer_result = vertcat(group);
293 |     else    
294 |         data_consumer_result = vertcat(data_consumer_result, group);
295 |     end
296 | end
297 | 
298 | 
299 | data_gen1 =  data_consumer_result;
300 | 
301 | data_gen_filtered = data_gen1(data_gen1.period ~= (num_period - num_period_obs + 1), :);
302 | 
303 | num_cond_obs_mileage = varfun(@numel, data_gen_filtered, 'InputVariables', [], ...
304 |     'GroupingVariables', {'lag_mileage_id', 'mileage_id', 'lag_action'});
305 | num_cond_obs_mileage.Properties.VariableNames{'GroupCount'} = 'num_cond_obs';
306 | 
307 | 
308 | num = height(num_cond_obs_mileage);
309 | 
310 | num_cond_obs_mileage_result = table();
311 | for i = 1:num
312 |     cond_obs_mileage = num_cond_obs_mileage(i,:);
313 | 
314 |     if cond_obs_mileage.lag_action == 0 && (cond_obs_mileage.lag_mileage_id >= 1 || cond_obs_mileage.lag_mileage_id<=20) && (cond_obs_mileage.lag_mileage_id == cond_obs_mileage.mileage_id || cond_obs_mileage.lag_action == 1) && cond_obs_mileage.mileage_id ==1
315 |         cond_obs_mileage.cond_obs_mileage = "cond_obs_mileage1";
316 |     elseif cond_obs_mileage.lag_action == 0 && (cond_obs_mileage.lag_mileage_id >=1 || cond_obs_mileage.lag_mileage_id <=19) && (cond_obs_mileage.lag_mileage_id == cond_obs_mileage.mileage_id-1 || cond_obs_mileage.lag_action == 1) && cond_obs_mileage.mileage_id == 2
317 |         cond_obs_mileage.cond_obs_mileage = "cond_obs_mileage2";
318 |     elseif cond_obs_mileage.lag_action == 0 && (cond_obs_mileage.lag_mileage_id >=1 || cond_obs_mileage.lag_mileage_id <=19) && (cond_obs_mileage.lag_mileage_id == cond_obs_mileage.mileage_id-2 || cond_obs_mileage.lag_action == 1) && cond_obs_mileage.mileage_id == 3
319 |         cond_obs_mileage.cond_obs_mileage = "cond_obs_mileage3";
320 |     elseif cond_obs_mileage.lag_action == 0 && cond_obs_mileage.lag_mileage_id == 20 && cond_obs_mileage.mileage_id == 21
321 |         cond_obs_mileage.cond_obs_mileage = "cond_abs_mileage4";
322 |     else 
323 |         cond_obs_mileage.cond_obs_mileage = "other";
324 |     end
325 | 
326 |     if i == 1
327 |         num_cond_obs_mileage_result = vertcat(cond_obs_mileage);
328 | 
329 |     else
330 |         num_cond_obs_mileage_result = [num_cond_obs_mileage_result; cond_obs_mileage];
331 |     end
332 | end
333 | 
334 | 
335 | filtered_data = num_cond_obs_mileage_result(num_cond_obs_mileage_result.cond_obs_mileage ~= "other", :);
336 | 
337 | 
338 | grouped_data = groupsummary(filtered_data, 'cond_obs_mileage', 'sum');
339 | 
340 | 
341 | result_matrix = table2array(grouped_data(:, 'sum_num_cond_obs'));
342 | 
343 | 
344 | kappa_est = zeros(1,2);
345 | 
346 | for i=1:4
347 |     if i > length(result_matrix)
348 |         result_matrix(i) = 1;
349 |     end
350 |     result_matrix(i);
351 | end 
352 | kappa_est(1) = (result_matrix(2) * (result_matrix(2) + result_matrix(3) + result_matrix(4))) / ((result_matrix(2) + result_matrix(3)) * (result_matrix(1) + result_matrix(2) + result_matrix(3) + result_matrix(4)));
353 | kappa_est(2) = (result_matrix(3) * (result_matrix(2) + result_matrix(3) + result_matrix(4))) / ((result_matrix(2) + result_matrix(3)) * (result_matrix(1) + result_matrix(2) + result_matrix(3) + result_matrix(4)));
354 | kappa_est = reshape(kappa_est, 2,1);
355 | Infomat_mileage_est = zeros(2,2);
356 | 
357 | Infomat_mileage_est(1,1) = (result_matrix(1)/(1-kappa_est(1) - kappa_est(2))^2)+ (result_matrix(2)/kappa_est(1)^2) + (result_matrix(4)/(kappa_est(1)+kappa_est(2))^2);
358 | Infomat_mileage_est(1,2) = (result_matrix(1)/(1-kappa_est(1) - kappa_est(2))^2)+ (result_matrix(4)/(kappa_est(1)+kappa_est(2))^2);
359 | Infomat_mileage_est(2,1) = Infomat_mileage_est(1,2);
360 | Infomat_mileage_est(2,2) = (result_matrix(1)/(1-kappa_est(1) - kappa_est(2))^2)+ (result_matrix(3)/kappa_est(2)^2) + (result_matrix(4)/(kappa_est(1)+kappa_est(2))^2);
361 | if isnan(Infomat_mileage_est(2,2))
362 |     Infomat_mileage_est(2,2) = 1;
363 | end
364 | 
365 | kappa_se = sqrt(diag(inv(Infomat_mileage_est)));
366 | 
367 | table(kappa_est, kappa_se)
368 | 
369 | 
370 | 
371 | 
372 | % 4.2 価格の遷移行列の推定
373 | 
374 | % # それぞれの確率が実現した観察の数を数える
375 | 
376 | % 1期目は推定に使えないため落とす
377 | data_gen3 = data_consumer_result;
378 | data_gen_filtered = data_gen3(data_gen3.period ~= (num_period - num_period_obs + 1), :);
379 | % t期の価格、t+1期の価格ごとにグループ化して、観察数を数える
380 | num_cond_obs_price = varfun(@numel, data_gen_filtered, 'InputVariables', [], ...
381 |     'GroupingVariables', {'lag_price_id', 'price_id'});
382 | num_cond_obs_price.Properties.VariableNames{'GroupCount'} = 'num_cond_obs';
383 | % 観察数を行列（num_price_states行の正方行列）に変換
384 | %   # price_id (t+1期の価格) を横に広げる
385 | num_cond_obs_price = pivot(num_cond_obs_price,Columns = "price_id", Rows = "lag_price_id",DataVariable="num_cond_obs");
386 | 
387 | num_cond_obs_price = removevars(num_cond_obs_price, 'lag_price_id');
388 | num_cond_obs_price = table2array(num_cond_obs_price);
389 | % 最尤法の解析解により推定値を求める
390 | for i=1:num_price_states
391 |     for j=1:num_price_states
392 |         if num_cond_obs_price(i,j) == 0
393 |             num_cond_obs_price(i,j) = 1;
394 |         end
395 |     end
396 | end
397 | lambda_est_mat = num_cond_obs_price./sum(num_cond_obs_price);
398 | lambda_est_mat
399 | 
400 | % 最尤法の解析解により標準誤差を求める
401 | 
402 | 
403 | 
404 | 
405 | lambda_se = [];
406 | matrixes = ones(num_price_states, num_price_states);
407 | 
408 | for i = 1:num_price_states
409 |    num_cond_obs_price_i = num_cond_obs_price(i,:);
410 | 
411 |    Infomat_price_est = diag(num_cond_obs_price_i([1:i-1,i+1:end]))./lambda_est_mat([1:i-1,i+1:end],[1:i-1,i+1:end]).^2+(num_cond_obs_price(i,i)./lambda_est_mat(i,i)^2).*matrixes([1:i-1,i+1:end],[1:i-1,i+1:end]);
412 | 
413 |    lambda_se = [lambda_se, sqrt(diag(inv(Infomat_price_est))).'];
414 | end
415 | 
416 | 
417 | lambda_se_mat = [0, lambda_se(1:6), 0, lambda_se(7:12), 0, lambda_se(13:18), 0, lambda_se(19:24), 0, lambda_se(25:30), 0];
418 | lambda_se_mat = reshape(lambda_se_mat, num_price_states, num_price_states).';
419 | 
420 | 
421 | 
422 | lambda_est = lambda_est_mat.';
423 | lambda_est = [lambda_est(2:7), lambda_est(9:14),lambda_est(16:21),lambda_est(23:28),lambda_est(30:35)];
424 | lambda_est = lambda_est(:);
425 | 
426 | 
427 | lambda_se_mat = lambda_se_mat.'
428 | lambda_es = [lambda_se_mat(2:7), lambda_se_mat(9:14),lambda_se_mat(16:21),lambda_se_mat(23:28),lambda_se_mat(30:35)];
429 | lambda_es = lambda_es(:);
430 | lambda_se_mat
431 | 
432 | table(lambda_est, lambda_es)
433 | 
434 | 
435 | % 5 パラメータの推定
436 | % 5.1 静学的なロジットによる推定
437 | 
438 | start_time = toc;
439 | 
440 | data_gen2 = data_consumer_result;
441 | 
442 | 
443 | data_gen2.Properties.VariableNames{'state_id'} = 'state_id_state_df';
444 | data_gen2.Properties.VariableNames{'mileage_id'} = 'mileage_id_state_df';
445 | data_gen2.Properties.VariableNames{'price'} = 'price_state_df';
446 | data_gen2.Properties.VariableNames{'mileage'} = 'mileage_state_df';
447 | data_gen2.Properties.VariableNames{'price_id'} = 'price_id_state_df';
448 | 
449 | 
450 | 
451 | 
452 | fun =@(param) logLH_stat(param, state_df, data_gen2);
453 | 
454 | param = theta_true;
455 | options = optimoptions(@lsqnonlin,'Algorithm','interior-point', 'Display','iter','MaxIter', 1500, 'MaxFunEvals', 10000);
456 | x = lsqnonlin(fun, param, [], [], options);
457 | 
458 | theta_est_stat = array2table(x, 'VariableNames',{'theta_c', 'theta_p'});
459 | disp(theta_est_stat);
460 | theta_est_stat = table2array(theta_est_stat);
461 | end_time = toc;
462 | 
463 | disp('Runtime:')
464 | 
465 | 
466 | disp(end_time - start_time);
467 | 
468 | param = theta_est_stat;
469 | 
470 | 
471 | [x,fval,exitflag,output,lambda,grad,hessian] = fmincon(fun,param);
472 | est_divide1 = 100000;
473 | est_divide2 = 1000000;
474 | theta_se_stat = sqrt(diag(inv(hessian)));
475 | theta_se_stat(1,1) = theta_se_stat(1,1)./est_divide1;
476 | theta_se_stat(2,1) = theta_se_stat(2,1)./est_divide2;
477 | theta_est_stat = reshape(theta_est_stat, 2,1);
478 | 
479 | table(theta_est_stat, theta_se_stat)
480 | 
481 | 
482 | % 5.2 不動点アルゴリズムによる推定
483 | 
484 | % 推定された遷移行列を取得
485 | 
486 | trans_mat_hat = [];
487 | 
488 | gen_mileage_trans_est = gen_mileage_trans(kappa_est, num_mileage_states, num_choice);
489 | 
490 | 
491 | trans_mat_hat.not_buy = kron(gen_mileage_trans_est(:,:,1), gen_price_trans(lambda_est));
492 | trans_mat_hat.buy = kron(gen_mileage_trans_est(:,:,2), gen_price_trans(lambda_est));
493 | 
494 | 
495 | start_time = toc;
496 | 
497 | fun =@(param) logLH(param, beta, trans_mat_hat, state_df, data_gen2, num_states, num_choice, Euler_const);
498 | 
499 | param = theta_true;
500 | options = optimoptions(@lsqnonlin,'Algorithm','interior-point', 'Display','iter','MaxIter', 1000, 'MaxFunEvals', 10000);
501 | x = lsqnonlin(fun, param, [], [], options);
502 | 
503 | NFXP_opt = x;
504 | 
505 | end_time = toc;
506 | disp("Runtime:")
507 | disp(end_time - start_time)
508 | 
509 | se_divide1 = 100000;
510 | se_divide2 = 1000000;
511 | theta_est = NFXP_opt;
512 | array2table(NFXP_opt, 'VariableNames',{'theta_c', 'theta_p'})
513 | 
514 | param = theta_est;
515 | 
516 | [x,fval,exitflag,output,lambda,grad,hessian] = fmincon(fun,param);
517 | 
518 | 
519 | theta_se = sqrt(diag(inv(hessian)));
520 | theta_se(1,1) = theta_se(1,1)./se_divide1;
521 | theta_se(2,1) = theta_se(2,1)./se_divide2;
522 | theta_est = reshape(theta_est, 2,1);
523 | table(theta_est, theta_se)
524 | 
525 | 
526 | 
527 | 
528 | 
529 | 
530 | 
531 | 
532 | 


--------------------------------------------------------------------------------
/M-test/test.m:
--------------------------------------------------------------------------------
 1 | 
 2 | % lambda_se = [];
 3 | % for i = 1:num_price_states
 4 | %    num_cond_obs_price_i = num_cond_obs_price1(i,:);
 5 | %    Infomat_price_est = diag(num_cond_obs_price_i([1:i-1,i+1:end]))./lambda_est_mat1([1:i-1,i+1:end],[1:i-1,i+1:end]).^2+(num_cond_obs_price1(i,i)./lambda_est_mat1(i,i)^2).*matrix([1:i-1,i+1:end],[1:i-1,i+1:end]);
 6 | % 
 7 | % 
 8 | %         lambda_se = [lambda_se, sqrt(diag(inv(Infomat_price_est)))'];
 9 | %         lambda_se
10 | % end
11 | % lambda_se_vector = [0, lambda_se(1:6), 0, lambda_se(7:12), 0, lambda_se(13:18), 0, lambda_se(19:24), 0, lambda_se(25:30), 0];
12 | % lambda_se_vector = reshape(lambda_se_vector, num_price_states, num_price_states).';
13 | % 
14 | % lambda_est_mat
15 | % lambda_est = lambda_est_mat.'
16 | % lambda_est = [lambda_est(2:7), lambda_est(9:14),lambda_est(16:21),lambda_est(23:28),lambda_est(30:35)]
17 | % lambda_est = lambda_est(:)
18 | % 
19 | % lambda_se_vector
20 | % lambda_se_vector = lambda_se_vector.'
21 | % lambda_es = [lambda_se_vector(2:7), lambda_se_vector(9:14),lambda_se_vector(16:21),lambda_se_vector(23:28),lambda_se_vector(30:35)]
22 | % lambda_es = lambda_es(:)
23 | % 
24 | % 
25 | % lambda_est = table(lambda_est, lambda_es);
26 | % 
27 | % lambda_est
28 | options = optimoptions('fminunc', 'Algorithm', 'trust-region', 'SpecifyObjectiveGradient', true, 'HessianFcn', 'objective', 'StepTolerance', 1e-20, 'FunctionTolerance', 1e-5, 'MaxIterations', 1000, 'MaxFunctionEvaluations', 10000);
29 | theta0 = zeros(n, 1);
30 | 
31 | [optTheta, functionVal, exitFlag] = fminunc(@(t) costFunction(X, y, lambda, t), theta0, options);
32 | 
33 | 
34 | 
35 | 


--------------------------------------------------------------------------------
/R-Test/.RData:
--------------------------------------------------------------------------------
https://raw.githubusercontent.com/GreatHub1204/Data-analysis-by-the-R-Program/74e45f3dc6d86d5b882c901772b7836739405d1b/R-Test/.RData


--------------------------------------------------------------------------------
/R-Test/.Rhistory:
--------------------------------------------------------------------------------
  1 | EV_old <- EV_new
  2 | }
  3 | EV <- EV_old
  4 | colnames(EV) <- c("EV_not_buy", "EV_buy")
  5 | return(EV)
  6 | }
  7 | start_time <- proc.time()
  8 | start_time
  9 | EV_true <- contraction(theta_true, beta, trans_mat_true, state_df)
 10 | end_time <- proc.time()
 11 | end_time
 12 | cat("Runtime:\n")
 13 | print((end_time - start_time)[[3]])
 14 | U_true <- flow_utility(theta_true, state_df)
 15 | U_true
 16 | V_CS_true <- U_true + beta*EV_true
 17 | colnames(V_CS_true) <- c("V_not_buy", "V_buy")
 18 | exp(V_CS_true[,"V_buy"])/rowSums(exp(V_CS_true))
 19 | prob_buy_true_mat <- matrix(exp(V_CS_true[,"V_buy"])/rowSums(exp(V_CS_true)),
 20 | nrow = num_price_states, ncol = num_mileage_states)
 21 | prob_buy_true_mat
 22 | num_consumer <- 1000
 23 | num_period <- 12 * 50
 24 | num_period_obs <- 12 * 10
 25 | num_obs <- num_consumer * num_period
 26 | trans_mat_cum <- list()
 27 | trans_mat_cum$not_buy <- t(apply(trans_mat_true$not_buy, 1, cumsum))
 28 | trans_mat_cum$buy <- t(apply(trans_mat_true$buy, 1, cumsum))
 29 | set.seed(1)
 30 | data_gen <-
 31 | dplyr::tibble(
 32 | consumer = rep(1:num_consumer, each = num_period),
 33 | period = rep(1:num_period, times = num_consumer),
 34 | eps_type1_not_buy = evd::rgev(num_obs,loc=0, scale=1, shape=0),
 35 | eps_type1_buy = evd::rgev(num_obs, loc=0, scale=1, shape=0),
 36 | eps_unif = runif(num_obs),
 37 | eps_price_state_unif = runif(num_obs),
 38 | state_id = 0,
 39 | action = 0
 40 | )
 41 | print(data_gen)
 42 | data_gen
 43 | generate_data <- function(df, V_CS, state_df, price_dist_steady) {
 44 | price_dist_steady_cumsum <- cumsum(price_dist_steady)
 45 | price_id_consumer <- 0
 46 | exceed_trans_prob_price <- TRUE
 47 | while(exceed_trans_prob_price) {
 48 | price_id_consumer <- price_id_consumer + 1
 49 | exceed_trans_prob_price <-
 50 | (df$eps_price_state_unif[1] >
 51 | price_dist_steady_cumsum[price_id_consumer])
 52 | }
 53 | df$state_id[1] <-  state_df %>%
 54 | dplyr::filter(mileage_id == 1) %>%
 55 | dplyr::filter(price_id == price_id_consumer) %>%
 56 | dplyr::select(state_id) %>%
 57 | as.numeric()
 58 | for (t in 1:(num_period-1)) {
 59 | state_id_today <- df$state_id[t]
 60 | if (V_CS[,'V_not_buy'][state_id_today] + df$eps_type1_not_buy[t] >
 61 | V_CS[,'V_buy'][state_id_today] + df$eps_type1_buy[t]){
 62 | df$action[t] <- 0
 63 | trans_mat_cum_today <- trans_mat_cum$not_buy
 64 | }else{
 65 | df$action[t] <- 1
 66 | trans_mat_cum_today <- trans_mat_cum$buy
 67 | }
 68 | state_id_tomorrow <- 0
 69 | exceed_trans_prob <- TRUE
 70 | while (exceed_trans_prob) {
 71 | state_id_tomorrow <- state_id_tomorrow + 1
 72 | trans_prob <- trans_mat_cum_today[state_id_today, state_id_tomorrow]
 73 | exceed_trans_prob <- (df$eps_unif[t] > trans_prob)
 74 | if(state_id_tomorrow >125){
 75 | break;
 76 | }
 77 | }
 78 | df$state_id[t+1]<- state_id_tomorrow
 79 | }
 80 | return(df)
 81 | }
 82 | data_gen <-
 83 | data_gen %>%
 84 | dplyr::group_split(consumer) %>%
 85 | purrr::map_dfr(generate_data,
 86 | V_CS = V_CS_true,
 87 | state_df = state_df,
 88 | price_dist_steady = price_dist_steady) %>%
 89 | dplyr::filter(period > (num_period - num_period_obs)) %>%
 90 | dplyr::left_join(state_df, by = 'state_id')
 91 | data_gen %>% tail(3)
 92 | rm(V_CS_true, trans_mat_cum)
 93 | data_gen %>%
 94 | dplyr::select(price, mileage, action) %>%
 95 | skimr::skim() %>%
 96 | skimr::yank("numeric") %>%
 97 | dplyr::select(skim_variable, mean, sd, p0, p100)
 98 | data_gen
 99 | data_gen %>%
100 | ggplot(aes(x = price)) + geom_histogram(binwidth = 100)
101 | data_gen %>%
102 | ggplot(aes(x = mileage)) + geom_histogram(binwidth = 5)
103 | data_gen %>%
104 | dplyr::group_by(mileage) %>%
105 | dplyr::summarize(num_state = n(),
106 | sum_action = sum(action)) %>%
107 | dplyr::mutate(prob_buy = sum_action / num_state) %>%
108 | ggplot(aes(x = mileage, y = prob_buy)) +
109 | geom_bar(stat = "identity")
110 | data_gen %>%
111 | dplyr::group_by(price) %>%
112 | dplyr::summarize(num_state = n(),
113 | sum_action = sum(action),
114 | .groups = 'drop') %>%
115 | dplyr::mutate(prob_buy = sum_action / num_state) %>%
116 | ggplot(aes(x = price, y = prob_buy)) +
117 | geom_bar(stat = "identity")
118 | prob_buy_obs_mat <-
119 | data_gen %>%
120 | dplyr::group_by(mileage,price) %>%
121 | dplyr::summarize(num_state = n(),
122 | sum_action = sum(action),
123 | .groups = 'drop') %>%
124 | dplyr::mutate(prob_buy = sum_action / num_state) %>%
125 | dplyr::select(prob_buy) %>%
126 | as.matrix() %>%
127 | matrix(nrow = num_price_states, ncol = num_mileage_states)
128 | prob_buy_obs_mat
129 | hist3D(x = mileage_states, y = price_states, z = t(prob_buy_obs_mat), zlim=c(0,0.4),
130 | bty = "g", phi = 10,  theta = -60, axes=TRUE,label=TRUE,
131 | xlab = "Mileage", ylab = "Price", zlab = "Probability", main = "Conditional probability of buying",
132 | col = "#0080ff", border = "blue", shade = 0.4,
133 | ticktype = "detailed", space = 0.05, d = 2, cex.axis = 0.8)
134 | data_gen
135 | data_gen <-
136 | data_gen %>%
137 | dplyr::group_by(consumer) %>%
138 | dplyr::mutate(lag_price_id = lag(price_id),
139 | lag_mileage_id = lag(mileage_id),
140 | lag_action = lag(action)) %>%
141 | dplyr::ungroup()
142 | data_gen
143 | num_cond_obs_mileage <-
144 | data_gen %>%
145 | # 1期目は推定に使えないため落とす
146 | dplyr::filter(period != (num_period - num_period_obs + 1)) %>%
147 | # t期の走行距離、t+1期の走行距離、t期の購買ごとにグループ化して、観察数を数える
148 | dplyr::group_by(lag_mileage_id, mileage_id, lag_action) %>%
149 | dplyr::summarise(num_cond_obs = n(),
150 | .groups = 'drop') %>%
151 | # 確率ごとに名前を割り当てる
152 | dplyr::mutate(
153 | cond_obs_mileage = case_when(
154 | # 1 - kappa_1 - kappa_2 の場合
155 | (
156 | (lag_action == 0 &
157 | between(lag_mileage_id, 1, 20) &
158 | (lag_mileage_id == mileage_id)) |
159 | (lag_action == 1 &
160 | mileage_id == 1)
161 | ) ~ 'cond_obs_mileage1',
162 | # kappa_1 の場合
163 | (
164 | (lag_action == 0 &
165 | between(lag_mileage_id, 1, 19) &
166 | (lag_mileage_id == mileage_id - 1)) |
167 | (lag_action == 1 &
168 | mileage_id == 2)
169 | ) ~ 'cond_obs_mileage2',
170 | # kappa_2 の場合
171 | (
172 | (lag_action == 0 &
173 | between(lag_mileage_id, 1, 19) &
174 | (lag_mileage_id == mileage_id - 2)) |
175 | (lag_action == 1 &
176 | mileage_id == 3)
177 | ) ~ 'cond_obs_mileage3',
178 | # kappa_1 + kappa_2 の場合
179 | (
180 | lag_action == 0 &
181 | lag_mileage_id == 20 &
182 | mileage_id == 21
183 | ) ~ 'cond_obs_mileage4',
184 | TRUE ~ 'other'
185 | )) %>%
186 | # 'other' は推定には使わないため落とす
187 | dplyr::filter(cond_obs_mileage != 'other') %>%
188 | # 確率ごとにグループ化し、再度、観察の数を数える
189 | dplyr::group_by(cond_obs_mileage) %>%
190 | dplyr::summarise(num_cond_obs = as.numeric(sum(num_cond_obs)),
191 | .groups = 'drop') %>%
192 | dplyr::select(num_cond_obs) %>%
193 | as.matrix()
194 | num_cond_obs_mileage
195 | kappa_est <- c()
196 | kappa_est[1] <-
197 | (num_cond_obs_mileage[2] *
198 | (num_cond_obs_mileage[2] + num_cond_obs_mileage[3] + num_cond_obs_mileage[4])) /
199 | ((num_cond_obs_mileage[2] + num_cond_obs_mileage[3]) *
200 | (num_cond_obs_mileage[1] + num_cond_obs_mileage[2] +
201 | num_cond_obs_mileage[3] + num_cond_obs_mileage[4]))
202 | kappa_est[2] <-
203 | (num_cond_obs_mileage[3] *
204 | (num_cond_obs_mileage[2] + num_cond_obs_mileage[3] + num_cond_obs_mileage[4])) /
205 | ((num_cond_obs_mileage[2] + num_cond_obs_mileage[3]) *
206 | (num_cond_obs_mileage[1] + num_cond_obs_mileage[2] +
207 | num_cond_obs_mileage[3] + num_cond_obs_mileage[4]))
208 | Infomat_mileage_est <- matrix(0, nrow = 2, ncol = 2)
209 | # 最尤法のフィッシャー情報量を求める
210 | Infomat_mileage_est[1,1] <-
211 | (num_cond_obs_mileage[1] / (1 - kappa_est[1] - kappa_est[2])^2) +
212 | (num_cond_obs_mileage[2] / kappa_est[1]^2) +
213 | (num_cond_obs_mileage[4] / (kappa_est[1]+kappa_est[2])^2)
214 | Infomat_mileage_est[1,2] <-
215 | (num_cond_obs_mileage[1] / (1 - kappa_est[1] - kappa_est[2])^2) +
216 | (num_cond_obs_mileage[4] / (kappa_est[1]+kappa_est[2])^2)
217 | Infomat_mileage_est[2,1] <- Infomat_mileage_est[1,2]
218 | Infomat_mileage_est[2,2] <-
219 | (num_cond_obs_mileage[1] / (1 - kappa_est[1] - kappa_est[2])^2) +
220 | (num_cond_obs_mileage[3] / kappa_est[2]^2) +
221 | (num_cond_obs_mileage[4] / (kappa_est[1]+kappa_est[2])^2)
222 | # 逆行列の対角要素の平方根が標準誤差になる
223 | kappa_se <- sqrt(diag(solve(Infomat_mileage_est)))
224 | dplyr::tibble(kappa_est, kappa_se)
225 | data_gen
226 | num_cond_obs_price <-
227 | data_gen %>%
228 | # 1期目は推定に使えないため落とす
229 | dplyr::filter(period != (num_period - num_period_obs + 1)) %>%
230 | # t期の価格、t+1期の価格ごとにグループ化して、観察数を数える
231 | dplyr::group_by(lag_price_id, price_id) %>%
232 | dplyr::summarise(num_cond_obs = n(),
233 | .groups = 'drop') %>%
234 | # 観察数を行列（num_price_states行の正方行列）に変換
235 | # price_id (t+1期の価格) を横に広げる
236 | tidyr::pivot_wider(names_from = "price_id",
237 | values_from = "num_cond_obs") %>%
238 | dplyr::select(!lag_price_id) %>%
239 | as.matrix()
240 | num_cond_obs_price
241 | rowSums(num_cond_obs_price)
242 | lambda_est_mat <-
243 | num_cond_obs_price / rowSums(num_cond_obs_price)
244 | lambda_est_mat
245 | lambda_se <- c()
246 | for (i in 1:num_price_states) {
247 | # 最尤法のフィッシャー情報量を求める
248 | Infomat_price_est <-
249 | diag(num_cond_obs_price[i,],
250 | num_price_states)[-i,-i] /
251 | (lambda_est_mat[-i,-i] ^ 2) +
252 | (num_cond_obs_price[i,i] /
253 | lambda_est_mat[i,i] ^ 2) *
254 | matrix(1, num_price_states, num_price_states)[-i,-i]
255 | lambda_se <- c(
256 | lambda_se,
257 | # 逆行列の対角要素の平方根が標準誤差になる
258 | sqrt(diag(solve(Infomat_price_est)))
259 | )
260 | }
261 | Infomat_price_est
262 | lambda_se
263 | lambda_se_mat <-
264 | c(0, lambda_se[1], lambda_se[2], lambda_se[3], lambda_se[4], lambda_se[5],
265 | lambda_se[6], 0, lambda_se[7], lambda_se[8], lambda_se[9], lambda_se[10],
266 | lambda_se[11], lambda_se[12], 0, lambda_se[13], lambda_se[14], lambda_se[15],
267 | lambda_se[16], lambda_se[17], lambda_se[18], 0, lambda_se[19], lambda_se[20],
268 | lambda_se[21], lambda_se[22], lambda_se[23], lambda_se[24], 0, lambda_se[25],
269 | lambda_se[26], lambda_se[27], lambda_se[28], lambda_se[29], lambda_se[30], 0) %>%
270 | matrix(ncol = num_price_states, nrow = num_price_states, byrow=T)
271 | lambda_se_mat
272 | lambda_est <- as.vector(t(lambda_est_mat))[c(-1,-8,-15,-22,-29,-36)]
273 | lambda_est
274 | dplyr::tibble(lambda_est, lambda_se)
275 | mat_ij <- Vectorize(
276 | function(i,j,mat) {mat[i,j]},
277 | vectorize.args = c("i", "j"))
278 | logLH_stat <- function(theta, state_df, df){
279 | # 選択毎の効用関数を求める
280 | U <- flow_utility(theta, state_df);
281 | # 選択確率を計算
282 | prob_C_stat <- exp(U) / rowSums(exp(U));
283 | # 対数尤度を計算
284 | mat_ij(df$state_id, df$action + 1, prob_C_stat);
285 | }
286 | start_time <- proc.time()
287 | data_gen
288 | # 最適化
289 | logLH_stat(theta_true, state_df,  data_gen)
290 | U <- flow_utility(theta_true, state_df)
291 | U
292 | prob_C_stat <- exp(U) / rowSums(exp(U));
293 | prob_C_stat
294 | logit_stat_opt <- optim(theta_true, logLH_stat,state_df = state_df, df = data_gen, control = list(fnscale = -1), method = "Nelder-Mead")
295 | data_gen
296 | View(data_gen)
297 | rm(list = ls())
298 | require(tidyverse)
299 | require(skimr)
300 | require(evd)
301 | require(numDeriv)
302 | require(graphics)
303 | library("plot3D")
304 | library("magrittr")
305 | library("dplyr")
306 | library('purrr')
307 | library("ggplot2")
308 | library('base')
309 | library('tidyr')
310 | theta_true <- c(theta_c = 0.004, theta_p = 0.003)
311 | beta <- 0.99
312 | Euler_const <- - digamma(1)
313 | Euler_const
314 | num_choice <- 2
315 | price_states <- seq(2000, 2500, by = 100)
316 | mileage_states <- seq(0, 100, by = 5)
317 | num_price_states <- length(price_states)
318 | num_mileage_states <- length(mileage_states)
319 | num_states <- num_price_states * num_mileage_states
320 | state_df <- dplyr::tibble(
321 | state_id = 1:num_states,
322 | price_id = rep(1:num_price_states, num_mileage_states),
323 | mileage_id = rep(1:num_mileage_states, each = num_price_states),
324 | price = rep(price_states, times = num_mileage_states),
325 | mileage = rep(mileage_states, each = num_price_states)
326 | )
327 | state_df %>% tail(3)
328 | gen_mileage_trans <- function(kappa){
329 | kappa_1 <- kappa[1]
330 | kappa_2 <- kappa[2]
331 | mileage_trans_mat_hat_not_buy <- matrix(0, ncol = num_mileage_states, nrow = num_mileage_states)
332 | for (i in 1:num_mileage_states) {
333 | for(j in 1:num_mileage_states){
334 | if(i == j){
335 | mileage_trans_mat_hat_not_buy[i,j] <- 1-kappa_1 - kappa_2
336 | }else if(i ==j-1){
337 | mileage_trans_mat_hat_not_buy[i, j] <- kappa_1
338 | }else if(i == j -1){
339 | mileage_trans_mat_hat_not_buy[i, j] <- kappa_2
340 | }
341 | }
342 | }
343 | mileage_trans_mat_hat_not_buy[num_mileage_states - 1, num_mileage_states] <- kappa_1 + kappa_2
344 | mileage_trans_mat_hat_not_buy[num_mileage_states, num_mileage_states] <- 1
345 | mileage_trans_mat_hat_buy <- matrix(1, nrow = num_mileage_states, ncol = 1) %*% mileage_trans_mat_hat_not_buy[1,]
346 | return(array(c(mileage_trans_mat_hat_not_buy,
347 | mileage_trans_mat_hat_buy),
348 | dim = c(num_mileage_states, num_mileage_states, num_choice)))
349 | }
350 | gen_price_trans <- function(lambda){
351 | lambda_11 <- 1 - lambda[1] - lambda[2] - lambda[3] - lambda[4] - lambda[5]
352 | lambda_22 <- 1 - lambda[6] - lambda[7] - lambda[8] - lambda[9] - lambda[10]
353 | lambda_33 <- 1 - lambda[11] - lambda[12] - lambda[13] - lambda[14] - lambda[15]
354 | lambda_44 <- 1 - lambda[16] - lambda[17] - lambda[18] - lambda[19] - lambda[20]
355 | lambda_55 <- 1 - lambda[21] - lambda[22] - lambda[23] - lambda[24] - lambda[25]
356 | lambda_66 <- 1 - lambda[26] - lambda[27] - lambda[28] - lambda[29] - lambda[30]
357 | price_trans_mat_hat <-
358 | c(lambda_11, lambda[1], lambda[2], lambda[3], lambda[4], lambda[5],
359 | lambda[6], lambda_22, lambda[7], lambda[8], lambda[9], lambda[10],
360 | lambda[11], lambda[12], lambda_33, lambda[13], lambda[14], lambda[15],
361 | lambda[16], lambda[17], lambda[18], lambda_44, lambda[19], lambda[20],
362 | lambda[21], lambda[22], lambda[23], lambda[24], lambda_55, lambda[25],
363 | lambda[26], lambda[27], lambda[28], lambda[29], lambda[30], lambda_66) %>%
364 | matrix(ncol = num_price_states, nrow = num_price_states, byrow=T)
365 | return(price_trans_mat_hat)
366 | }
367 | kappa_true <- c(0.25, 0.05)
368 | mileage_trans_mat_true <- gen_mileage_trans(kappa_true)
369 | mileage_trans_mat_true
370 | for(j in 1:num_mileage_states){
371 | if(i == j){
372 | mileage_trans_mat_hat_not_buy[i,j] <- 1-kappa_1 - kappa_2
373 | }else if(i ==j-1){
374 | mileage_trans_mat_hat_not_buy[i, j] <- kappa_1
375 | }else if(i == j -1){
376 | mileage_trans_mat_hat_not_buy[i, j] <- kappa_2
377 | }
378 | }
379 | for (i in 1:num_mileage_states) {
380 | for(j in 1:num_mileage_states){
381 | if(i == j){
382 | mileage_trans_mat_hat_not_buy[i,j] <- 1-kappa_1 - kappa_2
383 | }else if(i ==j-1){
384 | mileage_trans_mat_hat_not_buy[i, j] <- kappa_1
385 | }else if(i == j -1){
386 | mileage_trans_mat_hat_not_buy[i, j] <- kappa_2
387 | }
388 | }
389 | }
390 | mileage_trans_mat_hat_not_buy[num_mileage_states - 1, num_mileage_states] <- kappa_1 + kappa_2
391 | mileage_trans_mat_hat_not_buy[num_mileage_states, num_mileage_states] <- 1
392 | mileage_trans_mat_hat_buy <- matrix(1, nrow = num_mileage_states, ncol = 1) %*% mileage_trans_mat_hat_not_buy[1,]
393 | return(array(c(mileage_trans_mat_hat_not_buy,
394 | mileage_trans_mat_hat_buy),
395 | dim = c(num_mileage_states, num_mileage_states, num_choice)))
396 | gen_mileage_trans <- function(kappa){
397 | kappa_1 <- kappa[1]
398 | kappa_2 <- kappa[2]
399 | mileage_trans_mat_hat_not_buy <- matrix(0, ncol = num_mileage_states, nrow = num_mileage_states)
400 | for (i in 1:num_mileage_states) {
401 | for(j in 1:num_mileage_states){
402 | if(i == j){
403 | mileage_trans_mat_hat_not_buy[i,j] <- 1-kappa_1 - kappa_2
404 | }else if(i ==j-1){
405 | mileage_trans_mat_hat_not_buy[i, j] <- kappa_1
406 | }else if(i == j -1){
407 | mileage_trans_mat_hat_not_buy[i, j] <- kappa_2
408 | }
409 | }
410 | }
411 | mileage_trans_mat_hat_not_buy[num_mileage_states - 1, num_mileage_states] <- kappa_1 + kappa_2
412 | mileage_trans_mat_hat_not_buy[num_mileage_states, num_mileage_states] <- 1
413 | mileage_trans_mat_hat_buy <- matrix(1, nrow = num_mileage_states, ncol = 1) %*% mileage_trans_mat_hat_not_buy[1,]
414 | return(array(c(mileage_trans_mat_hat_not_buy,
415 | mileage_trans_mat_hat_buy),
416 | dim = c(num_mileage_states, num_mileage_states, num_choice)))
417 | }
418 | gen_price_trans <- function(lambda){
419 | lambda_11 <- 1 - lambda[1] - lambda[2] - lambda[3] - lambda[4] - lambda[5]
420 | lambda_22 <- 1 - lambda[6] - lambda[7] - lambda[8] - lambda[9] - lambda[10]
421 | lambda_33 <- 1 - lambda[11] - lambda[12] - lambda[13] - lambda[14] - lambda[15]
422 | lambda_44 <- 1 - lambda[16] - lambda[17] - lambda[18] - lambda[19] - lambda[20]
423 | lambda_55 <- 1 - lambda[21] - lambda[22] - lambda[23] - lambda[24] - lambda[25]
424 | lambda_66 <- 1 - lambda[26] - lambda[27] - lambda[28] - lambda[29] - lambda[30]
425 | price_trans_mat_hat <-
426 | c(lambda_11, lambda[1], lambda[2], lambda[3], lambda[4], lambda[5],
427 | lambda[6], lambda_22, lambda[7], lambda[8], lambda[9], lambda[10],
428 | lambda[11], lambda[12], lambda_33, lambda[13], lambda[14], lambda[15],
429 | lambda[16], lambda[17], lambda[18], lambda_44, lambda[19], lambda[20],
430 | lambda[21], lambda[22], lambda[23], lambda[24], lambda_55, lambda[25],
431 | lambda[26], lambda[27], lambda[28], lambda[29], lambda[30], lambda_66) %>%
432 | matrix(ncol = num_price_states, nrow = num_price_states, byrow=T)
433 | return(price_trans_mat_hat)
434 | }
435 | kappa_true <- c(0.25, 0.05)
436 | mileage_trans_mat_true <- gen_mileage_trans(kappa_true)
437 | mileage_trans_mat_true
438 | mileage_trans_mat_true[1:4, 1:4, 1]
439 | lambda_true <- c(0.1, 0.2, 0.2, 0.2, 0.2,
440 | 0.1, 0.2, 0.2, 0.2, 0.2,
441 | 0.1, 0.1, 0.2, 0.2, 0.1,
442 | 0.1, 0.1, 0.2, 0.2, 0.1,
443 | 0.05, 0.05, 0.1, 0.1, 0.2,
444 | 0.05, 0.05, 0.1, 0.1, 0.2)
445 | price_trans_mat_true <- gen_price_trans(lambda_true)
446 | price_trans_mat_true
447 | trans_mat_true <- list()
448 | mileage_trans_mat_true[,,1]
449 | trans_mat_true$not_buy <- mileage_trans_mat_true[,,1] %x% price_trans_mat_true
450 | trans_mat_true$buy <- mileage_trans_mat_true[,,2] %x% price_trans_mat_true
451 | price_trans_mat_true <- gen_price_trans(lambda_true)
452 | price_trans_mat_true
453 | trans_mat_true <- list()
454 | mileage_trans_mat_true[,,1]
455 | trans_mat_true$not_buy <- mileage_trans_mat_true[,,1] %x% price_trans_mat_true
456 | trans_mat_true$buy <- mileage_trans_mat_true[,,2] %x% price_trans_mat_true
457 | price_trans_eigen <- eigen(t(price_trans_mat_true))
458 | price_dist_steady <- price_trans_eigen$vectors[,1]/sum(price_trans_eigen$vectors[,1])
459 | flow_utility <- function(theta, state_df){
460 | theta_c <- theta[1]
461 | theta_p <- theta[2]
462 | U <-
463 | cbind(
464 | U_not_buy = - theta_c * state_df$mileage,
465 | U_buy = - theta_p * state_df$price
466 | )
467 | return(U)
468 | }
469 | print(trans_mat_true$not_buy)
470 | contraction <-
471 | function(theta, beta, trans_mat, state_df) {
472 | U <- flow_utility(theta, state_df)
473 | EV_old <- matrix(0, nrow = num_states, ncol = num_choice)
474 | diff <- 1000
475 | tol_level <- 1.0e-10
476 | while (diff > tol_level) {
477 | EV_new <- cbind(
478 | EV_not_buy <-
479 | Euler_const + trans_mat$not_buy %*% log(rowSums(exp(U + beta*EV_old))),
480 | EV_buy <-
481 | Euler_const + trans_mat$buy %*% log(rowSums(exp(U + beta*EV_old)))
482 | )
483 | diff <- sum(abs(EV_new-EV_old))
484 | EV_old <- EV_new
485 | }
486 | EV <- EV_old
487 | colnames(EV) <- c("EV_not_buy", "EV_buy")
488 | return(EV)
489 | }
490 | start_time <- proc.time()
491 | start_time
492 | EV_true <- contraction(theta_true, beta, trans_mat_true, state_df)
493 | end_time <- proc.time()
494 | end_time
495 | cat("Runtime:\n")
496 | print((end_time - start_time)[[3]])
497 | U_true <- flow_utility(theta_true, state_df)
498 | U_true
499 | V_CS_true <- U_true + beta*EV_true
500 | colnames(V_CS_true) <- c("V_not_buy", "V_buy")
501 | exp(V_CS_true[,"V_buy"])/rowSums(exp(V_CS_true))
502 | prob_buy_true_mat <- matrix(exp(V_CS_true[,"V_buy"])/rowSums(exp(V_CS_true)),
503 | nrow = num_price_states, ncol = num_mileage_states)
504 | prob_buy_true_mat
505 | num_consumer <- 1000
506 | num_period <- 12 * 50
507 | num_period_obs <- 12 * 10
508 | num_obs <- num_consumer * num_period
509 | trans_mat_cum <- list()
510 | trans_mat_cum$not_buy <- t(apply(trans_mat_true$not_buy, 1, cumsum))
511 | trans_mat_cum$buy <- t(apply(trans_mat_true$buy, 1, cumsum))
512 | trans_mat_cum
513 | 


--------------------------------------------------------------------------------
/R-Test/New Text Document.xlsx:
--------------------------------------------------------------------------------
https://raw.githubusercontent.com/GreatHub1204/Data-analysis-by-the-R-Program/74e45f3dc6d86d5b882c901772b7836739405d1b/R-Test/New Text Document.xlsx


--------------------------------------------------------------------------------
/R-Test/agentDynamic.R:
--------------------------------------------------------------------------------
  1 | rm(list = ls())
  2 | 
  3 | require(tidyverse)
  4 | require(skimr)
  5 | 
  6 | require(evd)
  7 | 
  8 | require(numDeriv)
  9 | require(graphics)
 10 | 
 11 | library("plot3D")
 12 | 
 13 | library("magrittr")
 14 | 
 15 | library("dplyr")
 16 | library('purrr')
 17 | 
 18 | library("ggplot2")
 19 | library('base')
 20 | library('tidyr')
 21 | 
 22 | theta_true <- c(theta_c = 0.004, theta_p = 0.003)   
 23 | 
 24 | beta <- 0.99
 25 | 
 26 | Euler_const <- - digamma(1)
 27 | 
 28 | Euler_const
 29 | 
 30 | num_choice <- 2
 31 | 
 32 | price_states <- seq(2000, 2500, by = 100)
 33 | 
 34 | mileage_states <- seq(0, 100, by = 5)
 35 | 
 36 | num_price_states <- length(price_states)
 37 | 
 38 | num_mileage_states <- length(mileage_states)
 39 | 
 40 | num_states <- num_price_states * num_mileage_states
 41 | 
 42 | state_df <- dplyr::tibble(
 43 |   state_id = 1:num_states,
 44 |   price_id = rep(1:num_price_states, num_mileage_states),
 45 |   mileage_id = rep(1:num_mileage_states, each = num_price_states),
 46 |   price = rep(price_states, times = num_mileage_states),
 47 |   mileage = rep(mileage_states, each = num_price_states)
 48 | )
 49 | 
 50 | 
 51 | state_df %>% tail(3)
 52 | 
 53 | gen_mileage_trans <- function(kappa){
 54 |   kappa_1 <- kappa[1]
 55 |   kappa_2 <- kappa[2]
 56 |   
 57 |   mileage_trans_mat_hat_not_buy <- matrix(0, ncol = num_mileage_states, nrow = num_mileage_states)
 58 |   for (i in 1:num_mileage_states) {
 59 |     for(j in 1:num_mileage_states){
 60 |       if(i == j){
 61 |         mileage_trans_mat_hat_not_buy[i,j] <- 1-kappa_1 - kappa_2
 62 |       }else if(i ==j-1){
 63 |         mileage_trans_mat_hat_not_buy[i, j] <- kappa_1
 64 |       }else if(i == j -1){
 65 |         mileage_trans_mat_hat_not_buy[i, j] <- kappa_2
 66 |       }
 67 |     }
 68 |   }
 69 |   
 70 |   mileage_trans_mat_hat_not_buy[num_mileage_states - 1, num_mileage_states] <- kappa_1 + kappa_2
 71 |   mileage_trans_mat_hat_not_buy[num_mileage_states, num_mileage_states] <- 1
 72 |   
 73 |   
 74 |   mileage_trans_mat_hat_buy <- matrix(1, nrow = num_mileage_states, ncol = 1) %*% mileage_trans_mat_hat_not_buy[1,]
 75 | 
 76 |   
 77 |   
 78 |   return(array(c(mileage_trans_mat_hat_not_buy,
 79 |                  mileage_trans_mat_hat_buy),
 80 |                dim = c(num_mileage_states, num_mileage_states, num_choice)))
 81 | }
 82 | 
 83 | gen_price_trans <- function(lambda){
 84 |   lambda_11 <- 1 - lambda[1] - lambda[2] - lambda[3] - lambda[4] - lambda[5]
 85 |   lambda_22 <- 1 - lambda[6] - lambda[7] - lambda[8] - lambda[9] - lambda[10]
 86 |   lambda_33 <- 1 - lambda[11] - lambda[12] - lambda[13] - lambda[14] - lambda[15]
 87 |   lambda_44 <- 1 - lambda[16] - lambda[17] - lambda[18] - lambda[19] - lambda[20]
 88 |   lambda_55 <- 1 - lambda[21] - lambda[22] - lambda[23] - lambda[24] - lambda[25]
 89 |   lambda_66 <- 1 - lambda[26] - lambda[27] - lambda[28] - lambda[29] - lambda[30]
 90 |   price_trans_mat_hat <- 
 91 |     c(lambda_11, lambda[1], lambda[2], lambda[3], lambda[4], lambda[5],
 92 |       lambda[6], lambda_22, lambda[7], lambda[8], lambda[9], lambda[10],
 93 |       lambda[11], lambda[12], lambda_33, lambda[13], lambda[14], lambda[15],
 94 |       lambda[16], lambda[17], lambda[18], lambda_44, lambda[19], lambda[20],
 95 |       lambda[21], lambda[22], lambda[23], lambda[24], lambda_55, lambda[25],
 96 |       lambda[26], lambda[27], lambda[28], lambda[29], lambda[30], lambda_66) %>% 
 97 |     matrix(ncol = num_price_states, nrow = num_price_states, byrow=T)
 98 |   return(price_trans_mat_hat)
 99 | }
100 | 
101 | kappa_true <- c(0.25, 0.05)
102 | 
103 | 
104 | mileage_trans_mat_true <- gen_mileage_trans(kappa_true)
105 | 
106 | mileage_trans_mat_true
107 | 
108 | mileage_trans_mat_true[1:4, 1:4, 1]
109 | 
110 | lambda_true <- c(0.1, 0.2, 0.2, 0.2, 0.2,
111 |                  0.1, 0.2, 0.2, 0.2, 0.2,
112 |                  0.1, 0.1, 0.2, 0.2, 0.1,
113 |                  0.1, 0.1, 0.2, 0.2, 0.1,
114 |                  0.05, 0.05, 0.1, 0.1, 0.2,
115 |                  0.05, 0.05, 0.1, 0.1, 0.2)
116 | 
117 | price_trans_mat_true <- gen_price_trans(lambda_true)
118 | 
119 | price_trans_mat_true
120 | 
121 | trans_mat_true <- list()
122 | 
123 | mileage_trans_mat_true[,,1]
124 | trans_mat_true$not_buy <- mileage_trans_mat_true[,,1] %x% price_trans_mat_true
125 | trans_mat_true$buy <- mileage_trans_mat_true[,,2] %x% price_trans_mat_true
126 | 
127 | 
128 | price_trans_eigen <- eigen(t(price_trans_mat_true))
129 | 
130 | price_dist_steady <- price_trans_eigen$vectors[,1]/sum(price_trans_eigen$vectors[,1])
131 | 
132 | 
133 | flow_utility <- function(theta, state_df){
134 |   theta_c <- theta[1]
135 |   theta_p <- theta[2]
136 |   U <- 
137 |     cbind(
138 |       
139 |       U_not_buy = - theta_c * state_df$mileage, 
140 |       
141 |       
142 |       U_buy = - theta_p * state_df$price
143 |     ) 
144 |   return(U)
145 | }
146 | 
147 | print(trans_mat_true$not_buy)
148 | 
149 | 
150 | 
151 | 
152 | 
153 | 
154 | 
155 | 
156 | 
157 | 
158 | contraction <- 
159 |   function(theta, beta, trans_mat, state_df) {
160 | 
161 |     U <- flow_utility(theta, state_df)
162 | 
163 |     EV_old <- matrix(0, nrow = num_states, ncol = num_choice)
164 | 
165 |     diff <- 1000
166 |  
167 |     tol_level <- 1.0e-10
168 |     
169 |     while (diff > tol_level) {
170 | 
171 |       EV_new <- cbind(
172 |         EV_not_buy <- 
173 |           Euler_const + trans_mat$not_buy %*% log(rowSums(exp(U + beta*EV_old))),
174 |         EV_buy <-
175 |           Euler_const + trans_mat$buy %*% log(rowSums(exp(U + beta*EV_old)))
176 |       )
177 | 
178 |       diff <- sum(abs(EV_new-EV_old))
179 |       
180 | 
181 |       EV_old <- EV_new
182 |     }
183 |     EV <- EV_old
184 |     colnames(EV) <- c("EV_not_buy", "EV_buy")
185 |     return(EV)
186 |   }
187 | 
188 | 
189 | start_time <- proc.time()
190 | start_time
191 | 
192 | EV_true <- contraction(theta_true, beta, trans_mat_true, state_df)
193 | 
194 | end_time <- proc.time()
195 | end_time
196 | 
197 | cat("Runtime:\n")
198 | 
199 | print((end_time - start_time)[[3]])
200 | 
201 | 
202 | U_true <- flow_utility(theta_true, state_df)
203 | U_true
204 | 
205 | V_CS_true <- U_true + beta*EV_true
206 | colnames(V_CS_true) <- c("V_not_buy", "V_buy")
207 | 
208 | exp(V_CS_true[,"V_buy"])/rowSums(exp(V_CS_true))
209 | prob_buy_true_mat <- matrix(exp(V_CS_true[,"V_buy"])/rowSums(exp(V_CS_true)), 
210 |                             nrow = num_price_states, ncol = num_mileage_states)
211 | prob_buy_true_mat
212 | 
213 | num_consumer <- 1000
214 | 
215 | num_period <- 12 * 50
216 | 
217 | num_period_obs <- 12 * 10
218 | 
219 | num_obs <- num_consumer * num_period
220 | 
221 | trans_mat_cum <- list()
222 | trans_mat_cum$not_buy <- t(apply(trans_mat_true$not_buy, 1, cumsum))
223 | 
224 | trans_mat_cum$buy <- t(apply(trans_mat_true$buy, 1, cumsum))
225 | 
226 | trans_mat_cum
227 | set.seed(1)
228 | 
229 | data_gen <- 
230 |   dplyr::tibble(
231 |     consumer = rep(1:num_consumer, each = num_period),
232 |     period = rep(1:num_period, times = num_consumer),
233 |     eps_type1_not_buy = evd::rgev(num_obs,loc=0, scale=1, shape=0),
234 |     eps_type1_buy = evd::rgev(num_obs, loc=0, scale=1, shape=0),
235 |     eps_unif = runif(num_obs),
236 |     eps_price_state_unif = runif(num_obs),
237 |     state_id = 0,
238 |     action = 0
239 |   )
240 | 
241 | print(data_gen)
242 | data_gen
243 | 
244 | 
245 | generate_data <- function(df, V_CS, state_df, price_dist_steady) {
246 |   
247 | 
248 |   price_dist_steady_cumsum <- cumsum(price_dist_steady)
249 | 
250 |   price_id_consumer <- 0
251 |   exceed_trans_prob_price <- TRUE
252 |   while(exceed_trans_prob_price) {
253 |     price_id_consumer <- price_id_consumer + 1
254 |     exceed_trans_prob_price <- 
255 |       (df$eps_price_state_unif[1] >
256 |          price_dist_steady_cumsum[price_id_consumer])
257 |   }
258 |   
259 | 
260 |   df$state_id[1] <-  state_df %>% 
261 |     dplyr::filter(mileage_id == 1) %>% 
262 |     dplyr::filter(price_id == price_id_consumer) %>% 
263 |     dplyr::select(state_id) %>% 
264 |     as.numeric()
265 |   
266 | 
267 |   for (t in 1:(num_period-1)) {
268 | 
269 |     state_id_today <- df$state_id[t]
270 |     
271 | 
272 |     if (V_CS[,'V_not_buy'][state_id_today] + df$eps_type1_not_buy[t] > 
273 |         V_CS[,'V_buy'][state_id_today] + df$eps_type1_buy[t]){
274 |       
275 | 
276 |       df$action[t] <- 0
277 |       
278 | 
279 |       trans_mat_cum_today <- trans_mat_cum$not_buy
280 |       
281 |     }else{
282 | 
283 |       df$action[t] <- 1
284 | 
285 |       trans_mat_cum_today <- trans_mat_cum$buy
286 |       
287 |     }
288 |     
289 | 
290 |     state_id_tomorrow <- 0
291 |     exceed_trans_prob <- TRUE
292 | 
293 |     while (exceed_trans_prob) {
294 |       state_id_tomorrow <- state_id_tomorrow + 1
295 |       trans_prob <- trans_mat_cum_today[state_id_today, state_id_tomorrow]
296 |       exceed_trans_prob <- (df$eps_unif[t] > trans_prob)
297 |       if(state_id_tomorrow >125){
298 |         break;
299 |       }
300 |     }
301 |     df$state_id[t+1]<- state_id_tomorrow
302 |   }
303 |   return(df)
304 | }
305 | 
306 | 
307 | data_gen <- 
308 |   data_gen %>%
309 |   dplyr::group_split(consumer) %>%
310 | 
311 |   purrr::map_dfr(generate_data,
312 |                  V_CS = V_CS_true,
313 |                  state_df = state_df, 
314 |                  price_dist_steady = price_dist_steady) %>% 
315 | 
316 |   dplyr::filter(period > (num_period - num_period_obs)) %>% 
317 | 
318 |   dplyr::left_join(state_df, by = 'state_id')
319 | 
320 | data_gen %>% tail(3)
321 | 
322 | 
323 | rm(V_CS_true, trans_mat_cum)
324 | 
325 | data_gen %>% 
326 |   dplyr::select(price, mileage, action) %>%
327 |   skimr::skim() %>% 
328 |   skimr::yank("numeric") %>% 
329 |   dplyr::select(skim_variable, mean, sd, p0, p100) 
330 | data_gen
331 |   
332 | data_gen %>%
333 |   ggplot(aes(x = price)) + geom_histogram(binwidth = 100)
334 | 
335 | 
336 | data_gen %>%
337 |   ggplot(aes(x = mileage)) + geom_histogram(binwidth = 5)
338 | 
339 | 
340 | 
341 | data_gen %>% 
342 |   dplyr::group_by(mileage) %>% 
343 |   dplyr::summarize(num_state = n(),
344 |                    sum_action = sum(action)) %>% 
345 |   dplyr::mutate(prob_buy = sum_action / num_state) %>% 
346 |   ggplot(aes(x = mileage, y = prob_buy)) + 
347 |   geom_bar(stat = "identity")
348 | 
349 | 
350 | data_gen %>% 
351 |   dplyr::group_by(price) %>% 
352 |   dplyr::summarize(num_state = n(),
353 |                    sum_action = sum(action),
354 |                    .groups = 'drop') %>% 
355 |   dplyr::mutate(prob_buy = sum_action / num_state) %>% 
356 |   ggplot(aes(x = price, y = prob_buy)) + 
357 |   geom_bar(stat = "identity")
358 | 
359 | prob_buy_obs_mat <- 
360 |   data_gen %>%
361 |   dplyr::group_by(mileage,price) %>%
362 |   dplyr::summarize(num_state = n(),
363 |                    sum_action = sum(action),
364 |                    .groups = 'drop') %>%
365 |   dplyr::mutate(prob_buy = sum_action / num_state) %>% 
366 |   dplyr::select(prob_buy) %>% 
367 |   as.matrix() %>% 
368 |   matrix(nrow = num_price_states, ncol = num_mileage_states)
369 | prob_buy_obs_mat
370 | 
371 | hist3D(x = mileage_states, y = price_states, z = t(prob_buy_obs_mat), zlim=c(0,0.4),
372 |        bty = "g", phi = 10,  theta = -60, axes=TRUE,label=TRUE,
373 |        xlab = "Mileage", ylab = "Price", zlab = "Probability", main = "Conditional probability of buying",
374 |        col = "#0080ff", border = "blue", shade = 0.4,
375 |       ticktype = "detailed", space = 0.05, d = 2, cex.axis = 0.8)
376 | data_gen
377 | 
378 | data_gen <- 
379 |   data_gen %>% 
380 |   dplyr::group_by(consumer) %>% 
381 |   dplyr::mutate(lag_price_id = lag(price_id),
382 |                 lag_mileage_id = lag(mileage_id),
383 |                 lag_action = lag(action)) %>% 
384 |     dplyr::ungroup() 
385 | 
386 | 
387 | data_gen
388 | 
389 | num_cond_obs_mileage <- 
390 |   data_gen %>% 
391 |   # 1期目は推定に使えないため落とす
392 |   dplyr::filter(period != (num_period - num_period_obs + 1)) %>% 
393 |   # t期の走行距離、t+1期の走行距離、t期の購買ごとにグループ化して、観察数を数える
394 |   dplyr::group_by(lag_mileage_id, mileage_id, lag_action) %>% 
395 |   dplyr::summarise(num_cond_obs = n(),
396 |                    .groups = 'drop') %>% 
397 |   # 確率ごとに名前を割り当てる
398 |   dplyr::mutate(
399 |     cond_obs_mileage = case_when(
400 |       # 1 - kappa_1 - kappa_2 の場合
401 |       (
402 |         (lag_action == 0 &
403 |            between(lag_mileage_id, 1, 20) &
404 |            (lag_mileage_id == mileage_id)) |
405 |           (lag_action == 1 & 
406 |              mileage_id == 1)
407 |       ) ~ 'cond_obs_mileage1',
408 |       # kappa_1 の場合
409 |       (
410 |         (lag_action == 0 &
411 |            between(lag_mileage_id, 1, 19) &
412 |            (lag_mileage_id == mileage_id - 1)) |
413 |           (lag_action == 1 & 
414 |              mileage_id == 2)
415 |       ) ~ 'cond_obs_mileage2',
416 |       # kappa_2 の場合
417 |       (
418 |         (lag_action == 0 &
419 |            between(lag_mileage_id, 1, 19) &
420 |            (lag_mileage_id == mileage_id - 2)) |
421 |           (lag_action == 1 & 
422 |              mileage_id == 3)
423 |       ) ~ 'cond_obs_mileage3',
424 |       # kappa_1 + kappa_2 の場合
425 |       (
426 |         lag_action == 0 &
427 |           lag_mileage_id == 20 &
428 |           mileage_id == 21
429 |       ) ~ 'cond_obs_mileage4',
430 |       TRUE ~ 'other'
431 |     )) %>% 
432 |   # 'other' は推定には使わないため落とす
433 |   dplyr::filter(cond_obs_mileage != 'other') %>% 
434 |   # 確率ごとにグループ化し、再度、観察の数を数える
435 |   dplyr::group_by(cond_obs_mileage) %>% 
436 |   dplyr::summarise(num_cond_obs = as.numeric(sum(num_cond_obs)),
437 |                    .groups = 'drop') %>% 
438 |   dplyr::select(num_cond_obs) %>% 
439 |   as.matrix() 
440 | 
441 | num_cond_obs_mileage 
442 | 
443 | 
444 | 
445 | kappa_est <- c()
446 | kappa_est[1] <- 
447 |   (num_cond_obs_mileage[2] * 
448 |      (num_cond_obs_mileage[2] + num_cond_obs_mileage[3] + num_cond_obs_mileage[4])) /
449 |   ((num_cond_obs_mileage[2] + num_cond_obs_mileage[3]) * 
450 |      (num_cond_obs_mileage[1] + num_cond_obs_mileage[2] + 
451 |         num_cond_obs_mileage[3] + num_cond_obs_mileage[4]))
452 | kappa_est[2] <- 
453 |   (num_cond_obs_mileage[3] * 
454 |      (num_cond_obs_mileage[2] + num_cond_obs_mileage[3] + num_cond_obs_mileage[4])) /
455 |   ((num_cond_obs_mileage[2] + num_cond_obs_mileage[3]) * 
456 |      (num_cond_obs_mileage[1] + num_cond_obs_mileage[2] + 
457 |         num_cond_obs_mileage[3] + num_cond_obs_mileage[4]))
458 | 
459 | Infomat_mileage_est <- matrix(0, nrow = 2, ncol = 2)
460 | 
461 | # 最尤法のフィッシャー情報量を求める
462 | Infomat_mileage_est[1,1] <- 
463 |   (num_cond_obs_mileage[1] / (1 - kappa_est[1] - kappa_est[2])^2) +
464 |   (num_cond_obs_mileage[2] / kappa_est[1]^2) +
465 |   (num_cond_obs_mileage[4] / (kappa_est[1]+kappa_est[2])^2)
466 | Infomat_mileage_est[1,2] <- 
467 |   (num_cond_obs_mileage[1] / (1 - kappa_est[1] - kappa_est[2])^2) +
468 |   (num_cond_obs_mileage[4] / (kappa_est[1]+kappa_est[2])^2)
469 | Infomat_mileage_est[2,1] <- Infomat_mileage_est[1,2]
470 | Infomat_mileage_est[2,2] <- 
471 |   (num_cond_obs_mileage[1] / (1 - kappa_est[1] - kappa_est[2])^2) +
472 |   (num_cond_obs_mileage[3] / kappa_est[2]^2) +
473 |   (num_cond_obs_mileage[4] / (kappa_est[1]+kappa_est[2])^2)
474 | 
475 | # 逆行列の対角要素の平方根が標準誤差になる
476 | kappa_se <- sqrt(diag(solve(Infomat_mileage_est)))
477 | 
478 | dplyr::tibble(kappa_est, kappa_se)
479 | data_gen
480 | num_cond_obs_price <- 
481 |   data_gen %>% 
482 |   # 1期目は推定に使えないため落とす
483 |   dplyr::filter(period != (num_period - num_period_obs + 1)) %>% 
484 |   # t期の価格、t+1期の価格ごとにグループ化して、観察数を数える
485 |   dplyr::group_by(lag_price_id, price_id) %>% 
486 |   dplyr::summarise(num_cond_obs = n(),
487 |                    .groups = 'drop') %>% 
488 |   # 観察数を行列（num_price_states行の正方行列）に変換
489 |   # price_id (t+1期の価格) を横に広げる
490 |   tidyr::pivot_wider(names_from = "price_id",
491 |                      values_from = "num_cond_obs") %>%
492 |   dplyr::select(!lag_price_id) %>% 
493 |   as.matrix()
494 | num_cond_obs_price
495 | 
496 | rowSums(num_cond_obs_price)
497 | 
498 | lambda_est_mat <- 
499 |   num_cond_obs_price / rowSums(num_cond_obs_price)
500 | lambda_est_mat
501 | 
502 | 
503 | 
504 | lambda_se <- c()
505 | for (i in 1:num_price_states) {
506 |   # 最尤法のフィッシャー情報量を求める
507 |   Infomat_price_est <- 
508 |     diag(num_cond_obs_price[i,],
509 |          num_price_states)[-i,-i] / 
510 |     (lambda_est_mat[-i,-i] ^ 2) + 
511 |     (num_cond_obs_price[i,i] / 
512 |        lambda_est_mat[i,i] ^ 2) *
513 |     matrix(1, num_price_states, num_price_states)[-i,-i]
514 |   lambda_se <- c(
515 |     lambda_se,
516 |     # 逆行列の対角要素の平方根が標準誤差になる
517 |     sqrt(diag(solve(Infomat_price_est)))
518 |   )
519 | }
520 | 
521 | Infomat_price_est
522 | lambda_se
523 | 
524 | 
525 | 
526 | lambda_se_mat <- 
527 |   c(0, lambda_se[1], lambda_se[2], lambda_se[3], lambda_se[4], lambda_se[5],
528 |     lambda_se[6], 0, lambda_se[7], lambda_se[8], lambda_se[9], lambda_se[10],
529 |     lambda_se[11], lambda_se[12], 0, lambda_se[13], lambda_se[14], lambda_se[15],
530 |     lambda_se[16], lambda_se[17], lambda_se[18], 0, lambda_se[19], lambda_se[20],
531 |     lambda_se[21], lambda_se[22], lambda_se[23], lambda_se[24], 0, lambda_se[25],
532 |     lambda_se[26], lambda_se[27], lambda_se[28], lambda_se[29], lambda_se[30], 0) %>% 
533 |   matrix(ncol = num_price_states, nrow = num_price_states, byrow=T)
534 | lambda_se_mat
535 | 
536 | lambda_est <- as.vector(t(lambda_est_mat))[c(-1,-8,-15,-22,-29,-36)]
537 | lambda_est
538 | dplyr::tibble(lambda_est, lambda_se)
539 | 
540 | 
541 | 
542 | mat_ij <- Vectorize(
543 |   function(i,j,mat) {mat[i,j]},
544 |   vectorize.args = c("i", "j"))
545 | 
546 | 
547 | logLH_stat <- function(theta, state_df, df){
548 |   
549 |   
550 |   # 選択毎の効用関数を求める
551 |   U <- flow_utility(theta, state_df);
552 |   # 選択確率を計算
553 |   prob_C_stat <- exp(U) / rowSums(exp(U));
554 | 
555 |   # 対数尤度を計算
556 |   mat_ij(df$state_id, df$action + 1, prob_C_stat);
557 | }
558 | 
559 | 
560 | 
561 | 
562 | 
563 | start_time <- proc.time()
564 | data_gen
565 | # 最適化
566 | logLH_stat(theta_true, state_df,  data_gen)
567 | 
568 | U <- flow_utility(theta_true, state_df)
569 | U
570 | prob_C_stat <- exp(U) / rowSums(exp(U));
571 | prob_C_stat
572 | 
573 | logit_stat_opt <- optim(theta_true, logLH_stat,state_df = state_df, df = data_gen, control = list(fnscale = -1), method = "Nelder-Mead")
574 | logit_stat_opt
575 | 
576 | 
577 | 
578 | 
579 | end_time <- proc.time()
580 | cat("Runtime:\n")
581 | 
582 | print((end_time - start_time)[[3]])
583 | 
584 | theta_true
585 | state_df
586 | 
587 | theta_est_stat <- logit_stat_opt$par
588 | theta_est_stat
589 | 
590 | logLH_stat(theta_true, state_df, data_gen);
591 | 
592 | hessian_stat <- numDeriv::hessian(func = logLH_stat, x = theta_est_stat, 
593 |                                   state_df = state_df, df = data_gen)
594 | hessian_stat 
595 | theta_se_stat <- sqrt(diag(solve(-hessian_stat)))
596 | 
597 | 
598 | theta_se_stat
599 | dplyr::tibble(theta_est_stat, theta_se_stat)
600 | 
601 | kappa_est
602 | 
603 | trans_mat_hat <- list()
604 | trans_mat_hat$not_buy <- 
605 |   gen_mileage_trans(kappa_est)[,,1] %x% gen_price_trans(lambda_est)
606 | trans_mat_hat$buy <- 
607 |   gen_mileage_trans(kappa_est)[,,2] %x% gen_price_trans(lambda_est)
608 | 
609 | 
610 | logLH <- function(theta, beta, trans_mat, state_df, df){
611 |   
612 |   # 選択ごとの期待価値関数を計算
613 |   EV <- contraction(theta, beta, trans_mat, state_df)
614 |   
615 |   # 選択毎の価値関数を定義する
616 |   U <- flow_utility(theta, state_df)
617 |   V_CS <- U + beta*EV
618 |   # 選択確率を計算
619 |   prob_C <- exp(V_CS) / rowSums(exp(V_CS))
620 |   # 対数尤度を計算
621 |   sum(log(mat_ij(df$state_id, df$action + 1, prob_C)))
622 | }
623 | 
624 | 
625 | start_time <- proc.time()
626 | 
627 | # 最適化
628 | NFXP_opt <- optim(theta_true, logLH,
629 |                   beta = beta, trans_mat = trans_mat_hat, state_df = state_df, df = data_gen, 
630 |                   control = list(fnscale = -1), 
631 |                   method = "Nelder-Mead")
632 | 
633 | end_time <- proc.time()
634 | cat("Runtime:\n")
635 | 
636 | print((end_time - start_time)[[3]])
637 | 
638 | theta_est <- NFXP_opt$par
639 | theta_est
640 | 
641 | 
642 | hessian <- numDeriv::hessian(func = logLH, x = theta_est, 
643 |                              beta = beta,　trans_mat = trans_mat_hat, state_df = state_df, df = data_gen)
644 | 
645 | theta_se <- sqrt(diag(solve(-hessian)))
646 | dplyr::tibble(theta_est, theta_se)
647 | 
648 | 
649 | 
650 | hessian <- matrix(c(0.4265,0.0059,0.0059,0.0001),nrow=2,ncol=2)
651 | 
652 | 
653 | solve(-hessian)
654 | 
655 | 
656 | 
657 | 


--------------------------------------------------------------------------------
/R-Test/plot.r:
--------------------------------------------------------------------------------
 1 | library(ggplot2)
 2 | 
 3 | # Generate some sample data, then compute mean and standard deviation
 4 | # in each group
 5 | set.seed(1)
 6 | df <- data.frame(
 7 |   gp = factor(rep(letters[1:3], each = 10)),
 8 |   y = rnorm(30)
 9 | )
10 | ds <- do.call(rbind, lapply(split(df, df$gp), function(d) {
11 |   data.frame(mean = mean(d$y), sd = sd(d$y), gp = d$gp)
12 | }))
13 | 
14 | # The summary data frame ds is used to plot larger red points on top
15 | # of the raw data. Note that we don't need to supply `data` or `mapping`
16 | # in each layer because the defaults from ggplot() are used.
17 | 


--------------------------------------------------------------------------------