R/PV.R

In knotion/PFSkit:

#' @title get_PV
#' @description Esta es una funcion de PFSkit
#' @details Esta funcion es parte del paquete PFS-kit
#' @examples
#' -------
#' @export
get_cognitive_params<-function(domain){
  #Anchor values from http://www.oecd.org/pisa/aboutpisa//PISA-based%20Test%20for%20Schools%20Technical%20Report%20-%20ACER%202012.pdf
  #Anex 5 page 195
  tmpdf<- readxl::read_excel(path = 'data/PISAFS-cognitive-parameters-2012.xlsx',
                     sheet = domain )
  taus <- (tmpdf%>%select(tau1))
  anchor_values <- c(tmpdf$Delta,as.vector(t(taus)))
  anchor_values_m<-na.omit(anchor_values)
  anchor_values<-anchor_values[!is.na(anchor_values)]
  anchor_values<-cbind(1:length(anchor_values),anchor_values)
  return(anchor_values)
}



#La implementación de esta funcion se basa en PfS_TechReport_CRC_final.pdf en el Anexo 2.
get_PV<-function(Q_cognitive,Q_context,domain=c('READ','MATH','SCIENCE'),npv=5){
  domainsq<-list('READ'='PR','MATH'='PM','SCIENCE'='PS')
  regresors<-get_dummies(Q_context,Q_cognitive)
  Q_cognitive<-Q_cognitive%>%rename('stidstd'=idUser_int)
  Q_pvs<-Q_cognitive%>%inner_join(regresors)
  PVlist<-list()
  for(d in domain){
    ids<-Q_pvs%>%select(stidstd)
    if(d=='READ'){
      regresors<-Q_pvs%>%select(contains('gender_dummy'),
                                           contains('idBooklet_dummy'),
                                           HISEI,
                                           contains('DR'),
                                           contains('pc'),
                                           contains('knotionCode_dummy')
      )%>%select(-contains('PISA4'))
    }else if(d=='MATH'){
      regresors<-Q_pvs%>%select(contains('gender_dummy'),
                                contains('idBooklet_dummy'),
                                HISEI,
                                contains('DM'),
                                contains('pc'),
                                contains('knotionCode_dummy')
      )%>%select(-contains('PISA5'))
    }else if(d=='SCIENCE'){
      regresors<-Q_pvs%>%select(contains('gender_dummy'),
                                contains('idBooklet_dummy'),
                                HISEI,
                                contains('DS'),
                                contains('pc'),
                                contains('knotionCode_dummy')
                                )%>%select(-contains('PISA3'),-stidstd)
    }
    #print(colnames(regresors))
    items<-Q_pvs%>%select(contains(domainsq[[d]]))
    items[items > 2]<-NA
    items[items < 0]<-NA
    anchor_values<-get_cognitive_params(d)
    #print(colnames(items))
    A1 <- TAM::.A.PCM2( resp = items)
    model<-TAM::tam(items,pid=ids$stidstd,
                   irtmodel="PCM2",
                   xsi.fixed = anchor_values,
                   A=A1,
                   Y=regresors,
                   verbose=FALSE
    )

    PVs<-TAM::tam.pv(model,nplausible =npv)$pv
    if(d=='READ'){
      PVlist[[d]]<-cbind(stidstd=PVs$pid,
                         (((0.883*(PVs[2:(npv+1)])-0.4837)/1.1002)*100+500)
                         )%>%
        rename(pv1read=PV1.Dim1,
               pv2read=PV2.Dim1,
               pv3read=PV3.Dim1,
               pv4read=PV4.Dim1,
               pv5read=PV5.Dim1)
    }else if(d=='MATH'){
      PVlist[[d]]<-cbind(stidstd=PVs$pid,
                         ((((PVs[2:(npv+1)])+0.1344)/1.2838)*100+500))%>%
        rename(pv1math=PV1.Dim1,
               pv2math=PV2.Dim1,
               pv3math=PV3.Dim1,
               pv4math=PV4.Dim1,
               pv5math=PV5.Dim1)
    }else if(d=='SCIENCE'){
      PVlist[[d]]<-cbind(stidstd=PVs$pid,
                         ((((PVs[2:(npv+1)])-0.1797)/1.0724)*100+500))%>%
        rename(pv1scie=PV1.Dim1,
               pv2scie=PV2.Dim1,
               pv3scie=PV3.Dim1,
               pv4scie=PV4.Dim1,
               pv5scie=PV5.Dim1)
    }
  }
  rwks<-Q_pvs%>%select(stidstd,knotionCode,pcvv1)
  rwks<-rwks[with(rwks, order(knotionCode, pcvv1)),]
  schoolsrwk<-rwks%>%group_by(knotionCode)%>%summarise(tam=n())%>%ungroup()
  H <- t(2*survey::hadamard(76)-1)
  Hsup<-structure(vapply(H, function(x) if(x==1) 1.5 else 0.5,
                         numeric(1)), dim=dim(H))
  Hinf<-structure(vapply(H, function(x) if(x==1) 0.5 else 1.5,
                  numeric(1)), dim=dim(H))
  HC<-matrix(0,nrow = 160,ncol=80)
  HC[seq(1,160,2),]=Hsup
  HC[seq(2,160,2),]=Hinf
  rwkM<-HC[1:schoolsrwk$tam[1],]
  for (row in schoolsrwk$tam[-1]){
    if(row%%2==0){
      rwkM<-rbind(rwkM,HC[1:row,])
    }else{
      rwkM<-rbind(rwkM,HC[1:(row-3),])
      H1<-H[(row-1)/2,]
      H2<-H[(row-1)/2,]
      H3<-H[(row-1)/2,]
      H1[H1==1]<-1.7071
      H1[H1==-1]<-0.2929
      H2[H2==-1]<-1.3536
      H2[H2==1]<-0.6464
      H3[H3==-1]<-1.3536
      H3[H3==1]<-0.6464
      rwkM<-rbind(rwkM,H1,H2,H3)
    }
  }
  colnames(rwkM)<-paste('rwgt',1:80,sep = "")
  rwkdf<-as.data.frame(cbind(stidstd=rwks$stidstd,rwkM))
  PValues<-PVlist%>%purrr::reduce(dplyr::inner_join,by='stidstd')
  return(PValues%>%dplyr::inner_join(rwkdf))

}
# input_pfs_context_mex_2018_clean<-output_StdQ_golddataset%>%
#   inner_join(input_pfs_context_mex_2018%>%select(stidstd,Testdate))
#
#
# pvs<-get_PV(input_pfs_cognitive_mex_2018,input_pfs_context_mex_2018)
# # print(nrow(pvs[['READ']]))
#  valsr<-pvs[['READ']] %>%
#    inner_join(output_StdQ_golddataset%>%
#                 select(stidstd,pv1read,pv2read,pv3read,pv4read,pv5read)%>%
#                 rename("pid"=stidstd), by=c("pid"="pid")
#               )
# valsr<-valsr[,order(colnames(valsr))]
#
# valsm<-pvs[['MATH']] %>%
#   inner_join(output_StdQ_golddataset%>%
#                select(stidstd,pv1math,pv2math,pv3math,pv4math,pv5math)%>%
#                rename("pid"=stidstd), by=c("pid"="pid")
#   )
# valsm<-valsm[,order(colnames(valsm))]