Créer une prévision pour les sous-ensembles de données et ajouter au fichier original

Question

J'utilise R 3.3.2.

Je voudrais prédire des dizaines d'établissements pour divers sous-locations en fonction de leurs résultats des années précédentes. Ensuite, j'ai besoin d'ajouter ces scores prédits en tant que nouvelles lignes à l'image originale. Mon entrée est un fichier csv

Je veux utiliser le modèle linéaire des moindres carrés et je trouve que "lm" et "predict" font exactement ce dont j'ai besoin.

Je sais que c'est une question assez débutante, mais j'espère que quelqu'un pourra m'aider. S'il vous plaît voir ci-dessous les données et le code avec deux solutions que j'ai commencé.

score<-c(63.6, 60.3, 60.4, 53.4, 46.5, 65.8, 45.8, 65.9, 
44.9, 60, 83.5, 81.7, 81.2, 78.8, 83.3, 79.4, 83.2, 77.3, 
79.4) 

year<-c(2013, 2014, 2015, 2016, 2014, 2014, 2015, 2015, 
2016, 2016, 2011, 2012, 2013, 2014, 2014, 2015, 2015, 
2016, 2016) 

institution<-c(1422, 1422, 1422, 1422, 1384, 1422, 1384, 
1422, 1384, 1422, 1384, 1384, 1384, 1422, 1384, 1422, 
1384, 1422, 1384) 

subranking<-c('CMP', 'CMP', 'CMP', 'CMP', 'SSC', 'SSC', 'SSC', 
'SSC', 'SSC', 'SSC', 'ETC', 'ETC', 'ETC', 'ETC', 'ETC', 'ETC', 
'ETC', 'ETC', 'ETC') 

d <- data.frame(score, year, institution,subranking) 


#-----------SOLUTION 1 ------------------- 

p<- unique(d$institution) 
for (i in (1:length(p))){ 
    x<- d$score[d$institution==p[i]] 
    y<- d$year[d$institution==p[i]] 
    model<- lm(x~y) 
    result<-predict(model, data.frame(y = c(2017,2018,2019,2020))) 
    z<- cbind(result,data.frame(y = c(2017,2018,2019,2020))) 
    print(z) 
} 

##----------SOLUTION 2 ------------------- 

calculate_predicted_scores <- function(scores, years) {predicted_scores <-0 
mod = lm(scores ~ years) 
predicted_scores<-predict(mod, data.frame(years = c(2017,2018,2019,2020))) 
return(predicted_scores) 
} 

Pour illustrer, voici ce que je veux à la fin - les lignes jaunes sont les prédictions:

Answer 1

Vous pouvez dplyr avec un balai comme décrit dans ce très utile answer

library(dplyr) 
library(broom) 
pred_per_group = d %>% group_by(subranking, institution) %>% 
    do(predicted_scores=predict(lm(score ~ year, data=.), data.frame(year = c(2017,2018,2019, 2020)))) 
pred_df = tidy(pred_per_group, predicted_scores) 

Ensuite, ajoutez la trame de données résultant avec predicitons à la vôtre avec rbind.

pred_df <- data.frame(score=pred_df$x, year=rep(c(2017,2018,2019,2020), 5), institution=pred_df$institution, subranking=pred_df$subranking) 
result <- rbind(d, pred_df) 

EDIT le 3 août: que vous vouliez conclure votre propre recherche de codage j'irais à ce sujet comme suit:

p<- unique(d$institution) 
r <- unique(d$subranking) 
for (i in (1:length(p))){ 
    for(j in seq_along(r)){ 
    score<- d$score[d$institution==p[i] & d$subranking==r[j]] 
    year<- d$year[d$institution==p[i] & d$subranking==r[j]] 
    if(length(score)== 0){ 
    print(sprintf("No level for the following combination: Institution: %s and Subrank: %s", p[i], r[j])) 
    } else{ 
    model<- lm(score~year) 
    result<-predict(model, data.frame(year = c(2017,2018,2019,2020))) 
    z<- cbind(result,data.frame(year = c(2017,2018,2019,2020))) 
    print(sprintf("For Institution: %s and Subrank: %s the Score is:",p[i], r[j])) 
    print(z) 
    } 
    } 
} 

donnant

[1] "For Institution: 1422 and Subrank: CMP the Score is:" 
    result year 
1 51.80 2017 
2 48.75 2018 
3 45.70 2019 
4 42.65 2020 
[1] "For Institution: 1422 and Subrank: SSC the Score is:" 
    result year 
1 58.1 2017 
2 55.2 2018 
3 52.3 2019 
4 49.4 2020 
[1] "For Institution: 1422 and Subrank: ETC the Score is:" 
    result year 
1 77.00 2017 
2 76.25 2018 
3 75.50 2019 
4 74.75 2020 
[1] "No level for the following combination: Institution: 1384 and Subrank: CMP" 
[1] "For Institution: 1384 and Subrank: SSC the Score is:" 
    result year 
1 44.13333 2017 
2 43.33333 2018 
3 42.53333 2019 
4 41.73333 2020 
[1] "For Institution: 1384 and Subrank: ETC the Score is:" 
    result year 
1 80.66000 2017 
2 80.26286 2018 
3 79.86571 2019 
4 79.46857 2020