Tune egmented нелинейной функции регрессии в R с сегментированным пакетом

Question

У меня есть df

df<-structure(list(x = c(97, 100, 101, 301, 302, 74, 75, 77, 78, 
79, 49, 50, 51, 52, 53, 54, 55, 56, 2, 3, 4, 5, 13, 14, 15, 16, 
17, 71, 72, 157, 160, 162, 163, 164, 165, 153, 154, 155, 71, 
72, 73, 74, 37, 38, 39, 40, 41, 40, 22, 23, 24, 13, 14, 15, 16, 
5, 6, 74, 75, 76, 77, 78, 79, 80, 81, 82, 126, 127, 128, 129, 
130, 131, 132, 71, 72, 73, 74, 75, 76, 1, 2, 3, 4, 5, 99, 100, 
101, 9, 10, 11, 3, 29, 30, 64, 65, 66, 198, 45, 46, 106, 107, 
108, 109, 110, 111, 112, 113, 114, 115, 116, 42, 43, 44, 45, 
46, 64, 65, 66, 67, 68, 69, 70, 71, 72, 73, 35, 36, 37, 38, 39, 
40, 41, 42, 43, 44, 81, 82, 83, 84, 85, 86, 54, 55, 56, 57, 58, 
59, 100, 101, 102, 37, 38, 39, 40, 41, 107, 110, 115, 9, 10, 
49, 50, 51, 52, 53, 54, 56, 64, 65, 66, 67, 68, 69, 1, 44, 45, 
46, 101, 105, 106, 107, 108, 109, 18, 19, 20, 199, 200, 201, 
203, 204, 205, 206, 34, 35, 37, 38, 39, 2, 18, 19, 21, 22, 26, 
69, 70, 77, 10, 131, 132, 133, 134, 135, 136, 137, 138, 139, 
46, 47, 17, 18, 35, 36, 84, 85, 86, 87, 88, 67, 70, 72, 73, 18, 
19, 20, 21, 96, 79, 11, 160, 161, 162, 163, 164, 42, 200, 50, 
250, 97, 30, 31), y = c(304.238143564202, 569.328627431765, 331.042528439313, 
739.620045015588, 220.96392728202, 152.264522056852, 90.1433769206633, 
14.9873599316925, 234.736409910023, 60.4167695627548, 380.654850683175, 
467.840079978108, 358.497598990798, 431.528439198621, 442.010991849005, 
351.189937948249, 343.098349086009, 357.122478995472, -518.123427070677, 
-554.919201846235, -614.669225180172, -391.545088194311, -124.396037524566, 
32.3765077856369, 43.199114789255, -88.3050879996736, 58.9395819107303, 
162.441016515717, 116.965395963751, 13.0217520870501, 17.828320314642, 
-16.2957513090223, 70.6350404303521, 45.2225155929918, 103.825463471585, 
-47.560741043475, -93.4213242912665, 20.1581508014351, 13.8083492300939, 
5.60939206456533, 31.3564232334029, 28.6217511966825, -146.205068191513, 
-121.016505045118, -115.100180697977, -82.8617020281963, -141.853484972846, 
-94.9308303585276, -64.6400166181847, -66.4285516217351, -42.6337259062566, 
-148.123950563371, -133.712445091456, -152.950761315413, -157.68036919646, 
-261.660716732062, -179.565574658569, 130.724638285115, 291.076604684815, 
121.960359405726, 164.323498383164, 348.140279591084, 129.706528767943, 
93.6406692401506, 8.05810943059623, 126.535503963009, 162.629432365065, 
64.9450473105535, 48.1501532075927, 23.6987462299876, 54.6846175976098, 
26.9417262496427, 46.334381384775, 91.8543458277127, 70.0609471213538, 
3.19760374492034, 45.6788141629659, 18.3098075923626, 51.8945797282504, 
-108.997818851843, -144.127755056645, -126.626824281528, -175.750439967494, 
-151.262252734334, 48.6587242824025, 15.2937245042995, 28.4606461951043, 
28.9567997518461, -68.2299433113076, -37.1677788909292, -108.258462657337, 
100.907804159913, 90.3369144331664, -50.4272195259109, 150.876719193533, 
102.855497308774, 42.9489971246803, -64.541020154953, -26.4363262676634, 
410.706475485116, 634.599768324755, 652.134194683167, 741.447446604259, 
661.473798044142, 578.514840453397, 631.346826186404, 451.460291288327, 
478.937328990083, 601.10946139507, 476.516531778732, 83.0877739411662, 
-20.7788411897491, 116.68308432959, 159.48955539451, 72.2584278024733, 
-17.8282854417339, -80.1063705889392, 62.7400574584608, 91.884871121496, 
136.065904535353, 165.27273714263, 61.1652030013502, 192.680280862842, 
101.131767969579, 55.857541423291, 223.296799821779, 287.345451676869, 
167.474206501152, 187.586917763576, 178.996818454005, 216.592342045158, 
123.907760241069, 240.175348138437, 134.714030943112, 198.285951606929, 
-35.3509976682253, 49.7211264978105, -32.3236237787642, -63.5224603935349, 
-67.8349593710154, -35.8055334035307, 233.031065647025, 287.956774678081, 
189.082761215046, 390.740067397826, 89.1989531565923, 155.527563805692, 
187.069480819977, 239.965034827124, 19.1234065489843, 174.082131403331, 
210.287920274772, 208.978041058406, 274.541879685828, 147.181517100893, 
411.59244894702, 521.862155947834, 583.104402136058, 515.216214198619, 
447.502872528043, 390.368216000032, 465.239609535784, 412.304880519398, 
415.90913855657, 373.556777236925, 474.047956492752, 582.261698205024, 
224.442115622107, 315.516411969438, 283.912847682368, 390.026366345584, 
322.790248586796, 312.50101460889, -638.973101716489, 260.730857435614, 
377.550341457129, 355.299060050398, 254.551377562806, 45.4501812993549, 
187.152575587854, 152.183998291846, 226.360116416588, 225.67982583819, 
724.559674147516, 274.952730934165, 533.868964495137, -284.477108941413, 
-266.881925489419, -273.690277403221, -156.337518987246, -87.4119132347405, 
-70.9132054951042, -93.5620291605592, 132.601979068451, -42.7843619789928, 
82.2957233709167, 8.36848279205151, 115.376620422816, -186.42650026083, 
603.835788675351, 522.096998542918, 587.1373909018, 564.061671742307, 
300.535339582537, 595.091753601562, 442.93324293429, 171.208900531754, 
-95.2025562002382, 217.845216980437, 241.779151081573, 214.481376983225, 
219.953942558961, 315.959296110785, 263.547381375218, 194.449290025979, 
305.158690313809, 326.318877183832, 251.31948431395, 485.374653904233, 
188.342473105964, 95.6089326666552, 113.006237091264, 207.492174458399, 
168.86071747914, 161.650970792165, 94.2879041660344, 174.897059062961, 
183.964235268068, 70.9266221858561, 338.1149700284, 185.940875658067, 
198.121665383659, 403.178600803018, 166.504583431408, 549.980685202405, 
395.059354009572, 71, 67, 60, -119, -34, -33, -68, -60, 292, 
270, 247, 100, 560, 60, -80)), .Names = c("x", "y"), row.names = c(919L, 
920L, 921L, 922L, 923L, 924L, 925L, 926L, 927L, 928L, 929L, 930L, 
931L, 932L, 933L, 934L, 935L, 936L, 937L, 938L, 939L, 940L, 941L, 
942L, 943L, 944L, 945L, 946L, 947L, 948L, 949L, 950L, 951L, 952L, 
953L, 954L, 955L, 956L, 957L, 958L, 959L, 960L, 961L, 962L, 963L, 
964L, 965L, 966L, 967L, 968L, 969L, 970L, 971L, 972L, 973L, 974L, 
975L, 976L, 977L, 978L, 979L, 980L, 981L, 982L, 983L, 984L, 985L, 
986L, 987L, 988L, 989L, 990L, 991L, 992L, 993L, 994L, 995L, 996L, 
997L, 998L, 999L, 1000L, 1001L, 1002L, 1003L, 1004L, 1005L, 1006L, 
1007L, 1008L, 1009L, 1010L, 1011L, 1012L, 1013L, 1014L, 1015L, 
1019L, 1020L, 1023L, 1024L, 1025L, 1026L, 1027L, 1028L, 1029L, 
1030L, 1031L, 1032L, 1033L, 1034L, 1035L, 1036L, 1037L, 1038L, 
1039L, 1040L, 1041L, 1042L, 1043L, 1044L, 1045L, 1046L, 1047L, 
1048L, 1049L, 1050L, 1051L, 1052L, 1053L, 1054L, 1055L, 1056L, 
1057L, 1058L, 1059L, 1060L, 1061L, 1062L, 1063L, 1064L, 1075L, 
1076L, 1077L, 1078L, 1079L, 1080L, 1081L, 1082L, 1083L, 1085L, 
1086L, 1087L, 1088L, 1089L, 1090L, 1091L, 1092L, 1098L, 1099L, 
1111L, 1112L, 1113L, 1114L, 1115L, 1116L, 1117L, 1118L, 1119L, 
1120L, 1121L, 1122L, 1123L, 1124L, 1125L, 1126L, 1127L, 1128L, 
1129L, 1130L, 1131L, 1132L, 1133L, 1134L, 1135L, 1136L, 1137L, 
1138L, 1139L, 1140L, 1141L, 1142L, 1143L, 1144L, 1145L, 1146L, 
1147L, 1148L, 1153L, 1156L, 1157L, 1158L, 1159L, 1160L, 1161L, 
1162L, 1176L, 1177L, 1187L, 1188L, 1189L, 1190L, 1191L, 1192L, 
1193L, 1194L, 1195L, 1196L, 1197L, 1199L, 1200L, 1202L, 1203L, 
1212L, 1213L, 1214L, 1215L, 1216L, 1217L, 1218L, 1219L, 1220L, 
1221L, 1222L, 1223L, 1224L, 2203L, 2204L, 2205L, 2206L, 2207L, 
2208L, 2209L, 2210L, 2211L, 2212L, 2213L, 2214L, 2215L, 2216L, 
2217L), class = "data.frame") 

Я приспособил нелинейную функцию к данным. Функция выглядит следующим образом:

f1<- function (x) {2.378735e+02*(exp(-3.295241e-03*x)) -7.878536e+02*(exp(-1.518790e-01*x))} 

Если я сюжет данных о моей функции она выглядит как ниже участок:

Однако, я хотел бы иметь более простую модель с линейной функцией. Поэтому я использовал segmented пакет для достижения того, что я хотел:

library (segmented) 
df$f_x<-2.378735e+02*(exp(-3.295241e-03*df$x)) -7.878536e+02*(exp(-1.518790e-01*df$x)) 

lm1<-lm(f_x~x, data=df) 
seg<-segmented(lm1,seg.Z=~x, psi=list(x=60)) 

Это работает очень хорошо, если один строит этот вывод на моих данных.

Однако я хотел бы ограничить значения перехвата при x = 0 и хотел бы извлечь выходную функцию, полученную из сегментации. Кто-нибудь знает как это делать?

Answer 1

Попробуйте нелинейные наименьшие квадраты с указанной функцией. Коэффициенты можно получить с помощью coef(fm).

library(minpack.lm) 

dfo <- df[order(df$x), ] 
fm <- nlsLM(y ~ pmin(b * x, A + B * x), dfo, start = list(b = 1, A = 1, B = 1)) 

plot(dfo) 
plot(fitted(fm) ~ x, dfo, col = "red") 

дает следующие коэффициенты и сюжет:

> fm 
Nonlinear regression model 
    model: y ~ pmin(b * x, A + B * x) 
    data: df 
     b  A  B 
    4.4745 273.6044 -0.8903 
residual sum-of-squares: 12279452 

Number of iterations to convergence: 25 
Achieved convergence tolerance: 1.49e-08