R/convert_to_latest.R

In arranhamlet/popvac_package: Generate population level vaccination data from a csv template.

#' Converts GADM version 1 and version 2 campaigns to version 2.8
#' Takes vaccination coverage and prior GADM levels and implements at GADM 2.8
#' @param shpvals Vaccination coverage at GADM1 or GADM2.8
#' @param shppop2.8 Population by GADM2.8
#' @param shp Shapefile to be converted to GADM 2.8
#' @param shp2.8 GADM2.8 shapefile.
#' @param id Tells the function which values its dealing with
#' @examples
#' convert_to_latest(vaccinationcoverage,population,AGO2,AGO2.8)
#' @keywords internal



convert_to_latest<-function(shpvals,shppop2.8,shp,shp2.8,id){
  
  #Depending on how many adm2 locations there are, we may want a finer raster.
  #Theres invariably loss of some of the population everytime we mask, but if we
  #increase the resolution of the raster then the overall % loss is lowered
  #Not an exact science as the % loss is influenced by the "wiggliness" of adm boundaries
  #Probably can be tuned a bit finer
  if(length(as.numeric(na.omit(shpvals)))!=0){
  
  #Abritrary 
  resvals<-5000

  #Variable for testing speed
  masked<- FALSE

  #Generate a blank raster
  r<-raster(ncol=resvals, nrow=resvals)

  #Give everything the same extent - the maximum of the two shapefiles
  extents<-sapply(1:4,function(x){
    max(extent(shp)[x],extent(shp2.8)[x])
  })
  extent(r)<-extent(extents)

  #Generate rasters from shapefiles
  #Old data
  shpvals0<-shpvals
  shpvals0[is.na(shpvals0)]<-0
  oldshpvac<-rasterize(shp, r,as.numeric((shpvals0)))

  #New data
  newshppop<-rasterize(shp2.8,r,shppop2.8)

  #Assign correct values to the new raster - total value/number of pixels per adm2 location
  newshprast_pixellist<-sapply(1:length(shp2.8), function(x){
    poly2<-shp2.8[x,]

    valuepop<-raster::rasterize(poly2,newshppop,mask=TRUE)

    newvalue<-as.numeric(na.omit(unique(values(valuepop))))/length(as.numeric(na.omit(values(valuepop))))
    valuepop[which(!is.na(values(valuepop)))]<-newvalue
    valuepop
  })
  # 
  newshprast_pixel<-raster::merge(stack(newshprast_pixellist))

  #Convert new to old
  newtooldpop<-sapply(1:length(shp@polygons), function(x){
    poly1<-shp[x,]
    populationrast<-raster::rasterize(poly1,newshprast_pixel,mask=TRUE)

    populationrast[which(!is.na(values(populationrast)))]<-sum(populationrast[which(!is.na(values(populationrast)))])/length(as.numeric(na.omit(values(populationrast))))
    populationrast
  })

  newoldgogo<-raster::merge(stack(newtooldpop))

  #Convert old to new
  polyvalsnew<-sapply(1:length(shp2.8@polygons), function(x){
    poly1<-shp2.8[x,]

    vacccoverage<-raster::rasterize(poly1,oldshpvac,mask=TRUE)
    populationrast<-raster::rasterize(poly1,newoldgogo,mask=TRUE)

    if(id %in% c(6,7,8)){
    vacpop<-vacccoverage*populationrast

    if(length(as.numeric(na.omit(values(vacpop))))==0){
      values(vacpop)<-0
    } else vacpop

        vacpop[which(!is.na(values(vacpop)))]<-sum(vacpop[which(!is.na(values(vacpop)))])/sum(populationrast[which(!is.na(values(populationrast)))])
    c("vacc"=vacpop,"pop"=sum(as.numeric(na.omit(values(populationrast)))))
    } else c("vacc"=if(length(as.numeric(names(table(na.omit(values(vacccoverage))))))==0) NA else (length(as.numeric(na.omit(values(vacccoverage))))/length(as.numeric(na.omit(values(oldshpvac)))))*as.numeric(na.omit(getValues(vacccoverage)))[1]
             ,"pop"=sum(as.numeric(na.omit(values(populationrast)))))
  })

  plot(shp2.8[shp2.8$ID_1==11,])
  plot(oldshpvac,add=TRUE)
  plot(shp2.8[shp2.8$ID_1==11,],add=TRUE)
  
  if(id %in% c(4,5)){
    vac<-polyvalsnew[1,]
    pop<-polyvalsnew[2,]
  } else {
    vac<-sapply(1:length(polyvalsnew[1,]), function(x) { if(length(as.numeric(na.omit(unique(values(polyvalsnew[1,][[x]])))))==0) 0 else as.numeric(na.omit(unique(values(polyvalsnew[1,][[x]]))))})
    pop<-sapply(1:length(polyvalsnew[2,]), function(x) { as.numeric(na.omit(unique((polyvalsnew[2,][[x]]))))})
  }

  valdf<-data.frame(as.data.frame(shp2.8)[,1:7],"vacc.cov"=vac,"pop"=pop,"id"=id)

  # # #Opposite of %in%
  '%!in%' <- function(x,y)!('%in%'(x,y))
  valdf<-valdf[which(valdf$vacc.cov %!in% NA),]
  valdf<-valdf[which(valdf$vacc.cov %!in% 0),]
  valdf
    
  } else NA
  
}